Session Modular_arithmetic_LLL_and_HNF_algorithms

Theory Matrix_Change_Row

section ‹Missing Matrix Operations›

text ‹In this theory we provide an operation that can change a single
  row in a matrix efficiently, and all other rows in the matrix implementation
  will be reused.›

(* TODO: move this part into JNF-AFP-entry *)

theory Matrix_Change_Row
  imports 
    Jordan_Normal_Form.Matrix_IArray_Impl
    Polynomial_Interpolation.Missing_Unsorted
begin

definition change_row :: "nat  (nat  'a  'a)  'a mat  'a mat" where
  "change_row k f A = mat (dim_row A) (dim_col A) (λ (i,j). 
     if i = k then f j (A $$ (k,j)) else A $$ (i,j))"

lemma change_row_carrier[simp]: 
  "(change_row k f A  carrier_mat nr nc) = (A  carrier_mat nr nc)" 
  "dim_row (change_row k f A) = dim_row A" 
  "dim_col (change_row k f A) = dim_col A" 
  unfolding change_row_def carrier_mat_def by auto

lemma change_row_index[simp]: "A  carrier_mat nr nc  i < nr  j < nc 
  change_row k f A $$ (i,j) = (if i = k then f j (A $$ (k,j)) else A $$ (i,j))" 
  "i < dim_row A  j < dim_col A  change_row k f A $$ (i,j) = (if i = k then f j (A $$ (k,j)) else A $$ (i,j))" 
  unfolding change_row_def by auto

lift_definition change_row_impl :: "nat  (nat  'a  'a)  'a mat_impl  'a mat_impl" is
  "λ k f (nr,nc,A). let Ak = IArray.sub A k; Arows = IArray.list_of A;
     Ak' = IArray.IArray (map (λ (i,c). f i c) (zip [0 ..< nc] (IArray.list_of Ak)));
     A' = IArray.IArray (Arows [k := Ak'])
     in (nr,nc,A')" 
proof (auto, goal_cases)
  case (1 k f nc b row)
  show ?case 
  proof (cases b)
    case (IArray rows)
    with 1 have "row  set rows  k < length rows 
        row = IArray (map (λ (i,c). f i c) (zip [0 ..< nc] (IArray.list_of (rows ! k))))"
      by (cases "k < length rows", auto simp: set_list_update dest: in_set_takeD in_set_dropD)
    with 1 IArray show ?thesis by (cases, auto)
  qed
qed

lemma change_row_code[code]: "change_row k f (mat_impl A) = (if k < dim_row_impl A 
  then mat_impl (change_row_impl k f A) 
  else Code.abort (STR ''index out of bounds in change_row'') (λ _. change_row k f (mat_impl A)))"
  (is "?l = ?r")
proof (cases "k < dim_row_impl A")
  case True
  hence id: "?r = mat_impl (change_row_impl k f A)" by simp
  show ?thesis unfolding id unfolding change_row_def
  proof (rule eq_matI, goal_cases)
    case (1 i j)
    thus ?case using True
      by (transfer, auto simp: mk_mat_def)
  qed (transfer, auto)+
qed simp

end

Theory Signed_Modulo

section ‹Signed Modulo Operation›

theory Signed_Modulo
  imports 
    Berlekamp_Zassenhaus.Poly_Mod
    Sqrt_Babylonian.Sqrt_Babylonian_Auxiliary
begin

text ‹The upcoming definition of symmetric modulo 
  is different to the HOL-Library-Signed\_Division.smod, since
  here the modulus will be in range $\{-m/2,...,m/2\}$, 
  whereas there -1 symmod m = m - 1.

  The advantage of have range $\{-m/2,...,m/2\}$ is that small negative
  numbers are represented by small numbers.

  One limitation is that the symmetric modulo is only working properly,
  if the modulus is a positive number.›

definition sym_mod :: "int  int  int" (infixl "symmod" 70) where
  "sym_mod x y = poly_mod.inv_M y (x mod y)"

lemma sym_mod_code[code]: "sym_mod x y = (let m = x mod y
   in if m + m  y then m else m - y)" 
  unfolding sym_mod_def poly_mod.inv_M_def Let_def ..

lemma sym_mod_zero[simp]: "n symmod 0 = n" "n > 0  0 symmod n = 0"
  unfolding sym_mod_def poly_mod.inv_M_def by auto

lemma sym_mod_range: "y > 0  x symmod y  {- ((y - 1) div 2) .. y div 2}"
  unfolding sym_mod_def poly_mod.inv_M_def using pos_mod_bound[of y x]
  by (cases "x mod y  y", auto) 
    (smt (verit) Euclidean_Division.pos_mod_bound Euclidean_Division.pos_mod_sign half_nonnegative_int_iff)+

text ‹The range is optimal in the sense that exactly y elements can be represented.›
lemma card_sym_mod_range: "y > 0  card {- ((y - 1) div 2) .. y div 2} = y" 
  by simp

lemma sym_mod_abs: "y > 0  ¦x symmod y¦ < y"
  "y  1  ¦x symmod y¦  y div 2"
  using sym_mod_range[of y x] by auto


lemma sym_mod_sym_mod[simp]: "x symmod y symmod y = x symmod (y :: int)" 
  unfolding sym_mod_def using poly_mod.M_def poly_mod.M_inv_M_id by auto

lemma sym_mod_diff_eq: "(a symmod c - b symmod c) symmod c = (a - b) symmod c" 
  unfolding sym_mod_def
  by (metis mod_diff_cong mod_mod_trivial poly_mod.M_def poly_mod.M_inv_M_id)

lemma sym_mod_sym_mod_cancel: "c dvd b  a symmod b symmod c = a symmod c" 
  using mod_mod_cancel[of c b] unfolding sym_mod_def
  by (metis poly_mod.M_def poly_mod.M_inv_M_id)

lemma sym_mod_diff_right_eq: "(a - b symmod c) symmod c = (a - b) symmod c" 
  using sym_mod_diff_eq by (metis sym_mod_sym_mod)

lemma sym_mod_mult_right_eq: "a * (b symmod c) symmod c = a * b symmod c" 
  unfolding sym_mod_def by (metis poly_mod.M_def poly_mod.M_inv_M_id mod_mult_right_eq)

lemma dvd_imp_sym_mod_0 [simp]:
  "b symmod a = 0" if "a > 0" "a dvd b"
  unfolding sym_mod_def poly_mod.inv_M_def using that by simp

lemma sym_mod_0_imp_dvd [dest!]:
  "b dvd a" if "a symmod b = 0"
  using that unfolding sym_mod_def poly_mod.inv_M_def
  by (smt (verit) Euclidean_Division.pos_mod_bound dvd_eq_mod_eq_0)

definition sym_div :: "int  int  int" (infixl "symdiv" 70) where
  "sym_div x y = (let d = x div y; m = x mod y in 
       if m + m  y then d else d + 1)"

lemma of_int_mod_integer: "(of_int (x mod y) :: integer) = (of_int x :: integer) mod (of_int y)" 
  using integer_of_int_eq_of_int modulo_integer.abs_eq by presburger

lemma sym_div_code[code]: 
  "sym_div x y = (let yy = integer_of_int y in 
     (case divmod_integer (integer_of_int x) yy
     of (d, m)  if m + m  yy then int_of_integer d else (int_of_integer (d + 1))))"
  unfolding sym_div_def Let_def divmod_integer_def split
  apply (rule if_cong, subst of_int_le_iff[symmetric], unfold of_int_add)
  by (subst (1 2) of_int_mod_integer, auto)

lemma sym_mod_sym_div: assumes y: "y > 0" shows "x symmod y = x - sym_div x y * y"
proof -
  let ?z = "x - y * (x div y)" 
  let ?u = "y * (x div y)" 
  have "x = y * (x div y) + x mod y" using y by simp
  hence id: "x mod y = ?z" by linarith
  have "x symmod y = poly_mod.inv_M y ?z" unfolding sym_mod_def id by auto
  also have " = (if ?z + ?z  y then ?z else ?z - y)" unfolding poly_mod.inv_M_def ..
  also have " = x - (if (x mod y) + (x mod y)  y then x div y else x div y + 1) * y" 
    by (simp add: algebra_simps id)
  also have "(if (x mod y) + (x mod y)  y then x div y else x div y + 1) = sym_div x y" 
    unfolding sym_div_def Let_def ..
  finally show ?thesis .
qed
  
lemma dvd_sym_div_mult_right [simp]:
  "(a symdiv b) * b = a" if "b > 0" "b dvd a"
  using sym_mod_sym_div[of b a] that by simp

lemma dvd_sym_div_mult_left [simp]:
  "b * (a symdiv b) = a" if "b > 0" "b dvd a"
  using dvd_sym_div_mult_right[OF that] by (simp add: ac_simps)


end

Theory Storjohann_Mod_Operation

section ‹Storjohann's Lemma 13›

text ‹This theory contains the result that one can always perform a mod-operation on
  the entries of the $d\mu$-matrix.›

theory Storjohann_Mod_Operation
  imports 
    LLL_Basis_Reduction.LLL_Certification
    Signed_Modulo
begin 

lemma map_vec_map_vec: "map_vec f (map_vec g v) = map_vec (f o g) v" 
  by (intro eq_vecI, auto)

context semiring_hom
begin

(* TODO: move *)
lemma mat_hom_add: assumes A: "A  carrier_mat nr nc" and B: "B  carrier_mat nr nc"
  shows "math (A + B) = math A + math B"
  by (intro eq_matI, insert A B, auto simp: hom_add)
end

text ‹We now start to prove lemma 13 of Storjohann's paper.›
context
  fixes A I :: "'a :: field mat" and n :: nat
  assumes A: "A  carrier_mat n n" 
  and det: "det A  0" 
  and I: "I = the (mat_inverse A)" 
begin
lemma inverse_via_det: "I * A = 1m n" "A * I = 1m n" "I  carrier_mat n n" 
  "I = mat n n (λ (i,j). det (replace_col A (unit_vec n j) i) / det A)"
proof -
  from det_non_zero_imp_unit[OF A det] 
  have Unit: "A  Units (ring_mat TYPE('a) n n)" .
  from mat_inverse(1)[OF A, of n] Unit I have "mat_inverse A = Some I" 
    by (cases "mat_inverse A", auto)
  from mat_inverse(2)[OF A this]
  show left: "I * A = 1m n" and right: "A * I = 1m n" and I: "I  carrier_mat n n" 
    by blast+
  {
    fix i j
    assume i: "i < n" and j: "j < n" 
    from I i j have cI: "col I j $ i = I $$ (i,j)" by simp
    from j have uv: "unit_vec n j  carrier_vec n" by auto
    from j I have col: "col I j  carrier_vec n" by auto
    from col_mult2[OF A I j, unfolded right] j
    have "A *v col I j = unit_vec n j" by simp
    from cramer_lemma_mat[OF A col i, unfolded this cI]
    have "I $$ (i,j) = det (replace_col A (unit_vec n j) i) / det A" using det by simp
  }
  thus "I = mat n n (λ (i,j). det (replace_col A (unit_vec n j) i) / det A)"
    by (intro eq_matI, use I in auto)
qed

lemma matrix_for_singleton_entry: assumes i: "i < n" and 
  j: "j < n" 
  and Rdef: "R = mat n n ( λ ij. if ij = (i,j) then c :: 'a else 0)" 
shows "mat n n
   (λ(i', j'). if i' = i then c * det (replace_col A (unit_vec n j') j) / det A
       else 0) * A = R" 
proof -
  note I = inverse_via_det(3)
  have R: "R  carrier_mat n n" unfolding Rdef by auto
  have "(R * I) * A = R * (I * A)" using I A R by auto
  also have "I * A = 1m n" unfolding inverse_via_det(1) ..
  also have "R *  = R" using R by simp
  also have "R * I = mat n n (λ (i',j'). row R i'  col I j')"
    using I R unfolding times_mat_def by simp
  also have " = mat n n ( λ (i',j'). if i' = i then c * I $$ (j, j') else 0)" 
    (is "mat n n ?f = mat n n ?g")
  proof -
    {
      fix i' j'
      assume i': "i' < n" and j': "j' < n" 
      have "?f (i',j') = ?g (i',j')" 
      proof (cases "i' = i")
        case False
        hence "row R i' = 0v n" unfolding Rdef using i'
          by (intro eq_vecI, auto simp: Matrix.row_def)
        thus ?thesis using False i' j' I by simp
      next
        case True
        hence "row R i' = c v unit_vec n j" unfolding Rdef using i' j' i j
          by (intro eq_vecI, auto simp: Matrix.row_def)
        with True show ?thesis using i' j' I j by simp
      qed
    }
    thus ?thesis by auto
  qed
  finally show ?thesis unfolding inverse_via_det(4) using j 
    by (auto intro!: arg_cong[of _ _ "λ x. x * A"])
qed
end

lemma (in gram_schmidt_fs_Rn) det_M_1: "det (M m) = 1" 
proof -
  have "det (M m) = prod_list (diag_mat (M m))" 
    by (rule det_lower_triangular[of m], auto simp: μ.simps)
  also have " = 1" 
    by (rule prod_list_neutral, auto simp: diag_mat_def μ.simps)
  finally show ?thesis .
qed

context gram_schmidt_fs_int
begin
lemma assumes IM: "IM = the (mat_inverse (M m))" 
  shows inv_mu_lower_triangular: " k i. k < i  i < m  IM $$ (k, i) = 0"
  and inv_mu_diag: " k. k < m  IM $$ (k, k) = 1"
  and d_inv_mu_integer: " i j. i < m  j < m  d i * IM $$ (i,j)  " 
  and inv_mu_inverse: "IM * M m = 1m m" "M m * IM = 1m m" "IM  carrier_mat m m" 
proof - 
  note * = inverse_via_det[OF M_dim(3) _ IM, unfolded det_M_1]
  from * show inv: "IM * M m = 1m m" "M m * IM = 1m m" 
    and IM: "IM  carrier_mat m m"  by auto
  from * have IM_det: "IM = mat m m (λ(i, j). det (replace_col (M m) ((unit_vec m) j) i))" 
    by auto
  from matrix_equality have "IM * FF = IM * ((M m) * Fs)" by simp
  also have " = (IM * M m) * Fs" using M_dim(3) IM Fs_dim(3)
    by (metis assoc_mult_mat)
  also have " = Fs" unfolding inv using Fs_dim(3) by simp
  finally have equality: "IM * FF = Fs" .
  {
    fix i k
    assume i: "k < i" "i < m" 
    show "IM $$ (k, i) = 0" using i M_dim unfolding IM_det
      by (simp, subst det_lower_triangular[of m], auto simp: replace_col_def μ.simps diag_mat_def)
  } note IM_lower_triag = this
  {
    fix k
    assume k: "k < m" 
    show "IM $$ (k,k) = 1" using k M_dim unfolding IM_det
      by (simp, subst det_lower_triangular[of m], auto simp: replace_col_def μ.simps diag_mat_def
        intro!: prod_list_neutral)
  } note IM_diag_1 = this
  {
    fix k
    assume k: "k < m" 
    let ?f = "λ i. IM $$ (k, i) v fs ! i" 
    let ?sum = "M.sumlist (map ?f [0..<m])" 
    let ?sumk = "M.sumlist (map ?f [0..<k])" 
    have set: "set (map ?f [0..<m])  carrier_vec n" using fs_carrier by auto
    hence sum: "?sum  carrier_vec n" by simp
    from set k have setk: "set (map ?f [0..<k])  carrier_vec n" by auto
    hence sumk: "?sumk  carrier_vec n" by simp
    from sum have dim_sum: "dim_vec ?sum = n" by simp
    have "gso k = row Fs k" using k by auto
    also have " = row (IM * FF) k" unfolding equality ..
    also have "IM * FF = mat m n (λ (i,j). row IM i   col FF j)" 
      unfolding times_mat_def using IM FF_dim by auto
    also have "row  k = vec n (λ j. row IM k  col FF j)" 
      unfolding Matrix.row_def using IM FF_dim k by auto
    also have " = vec n (λ j.  i < m. IM $$ (k, i) * fs ! i $ j)" 
      by (intro eq_vecI, insert IM k, auto simp: scalar_prod_def Matrix.row_def intro!: sum.cong)
    also have " = ?sum" 
      by (intro eq_vecI, insert IM, unfold dim_sum, subst sumlist_vec_index, 
        auto simp: o_def sum_list_sum_nth intro!: sum.cong)
    also have "[0..<m] = [0..<k] @ [k] @ [Suc k ..<m]" using k
      by (simp add: list_trisect)
    also have "M.sumlist (map ?f ) = ?sumk + 
      (?f k + M.sumlist (map ?f [Suc k ..< m]))" 
      unfolding map_append 
      by (subst M.sumlist_append; (subst M.sumlist_append)?, insert k fs_carrier, auto)
    also have "M.sumlist (map ?f [Suc k ..< m]) = 0v n" 
      by (rule sumlist_neutral, insert IM_lower_triag, auto)
    also have "IM $$ (k,k) = 1" using IM_diag_1[OF k] .
    finally have gso: "gso k = ?sumk + fs ! k"  using k by simp
    define b where "b = vec k (λ j. fs ! j  fs ! k)" 
    {
      fix j
      assume jk: "j < k" 
      with k have j: "j < m" by auto
      have "fs ! j  gso k = fs ! j  (?sumk + fs ! k)" 
        unfolding gso by simp
      also have "fs ! j  gso k = 0" using jk k
        by (simp add: fi_scalar_prod_gso gram_schmidt_fs.μ.simps)
      also have "fs ! j  (?sumk + fs ! k)
         = fs ! j  ?sumk + fs ! j  fs ! k" 
        by (rule scalar_prod_add_distrib[OF _ sumk], insert j k, auto)
      also have "fs ! j  fs ! k = b $ j" unfolding b_def using jk by simp
      finally have "b $ j = - (fs ! j  ?sumk)" by linarith
    } note b_index = this
    let ?x = "vec k (λ i. - IM $$ (k, i))" 
    have x: "?x  carrier_vec k" by auto
    from k have km: "k  m" by simp 
    have bGx: "b = Gramian_matrix fs k *v (vec k (λ i. - IM $$ (k, i)))" 
      unfolding Gramian_matrix_alt_alt_def[OF km]
    proof (rule eq_vecI; simp)
      fix i
      assume i: "i < k" 
      have "b $ i = - (x[0..<k]. fs ! i  (IM $$ (k, x) v fs ! x))" 
        unfolding b_index[OF i]
        by (subst scalar_prod_right_sum_distrib, insert setk i k, auto simp: o_def)
      also have " = vec k (λj. fs ! i  fs ! j)  vec k (λi. - IM $$ (k, i))" 
        by (subst (3) scalar_prod_def, insert i k, auto simp: o_def sum_list_sum_nth simp flip: sum_negf
          intro!: sum.cong)
      finally show "b $ i = vec k (λj. fs ! i  fs ! j)  vec k (λi. - IM $$ (k, i))" .
    qed (simp add: b_def)
    have G: "Gramian_matrix fs k  carrier_mat k k" 
      unfolding Gramian_matrix_alt_alt_def[OF km] by simp
    from cramer_lemma_mat[OF G x, folded bGx Gramian_determinant_def]
    have "i < k  
      d k * IM $$ (k, i) = - det (replace_col (Gramian_matrix fs k) (vec k (λ j. fs ! j  fs ! k)) i)" 
      for i unfolding b_def by simp
  } note IM_lower_values = this
  {
    fix i j
    assume i: "i < m" and j: "j < m" 
    from i have im: "i  m" by auto
    consider (1) "j < i" | (2) "j = i" | (3) "i < j" by linarith
    thus "d i * IM $$ (i,j)  "
    proof cases
      case 1
      show ?thesis unfolding IM_lower_values[OF i 1] replace_col_def Gramian_matrix_alt_alt_def[OF im]
        by (intro Ints_minus Ints_det, insert i j, auto intro!: Ints_scalar_prod[of _ n] fs_int)
    next
      case 3
      show ?thesis unfolding IM_lower_triag[OF 3 j] by simp
    next
      case 2
      show ?thesis unfolding IM_diag_1[OF i] 2 using i unfolding Gramian_determinant_def
         Gramian_matrix_alt_alt_def[OF im]
        by (intro Ints_mult Ints_det, insert i j, auto intro!: Ints_scalar_prod[of _ n] fs_int)
    qed 
  }
qed

definition inv_mu_ij_mat :: "nat  nat  int  int mat" where
 "inv_mu_ij_mat i j c = (let
    B = mat m m (λ ij. if ij = (i,j) then c else 0);
    C = mat m m (λ (i,j). the_inv (of_int :: _  'a) (d i * the (mat_inverse (M m)) $$ (i,j)))
   in B * C + 1m m)" 

lemma inv_mu_ij_mat: assumes i: "i < m" and ji: "j < i" 
  shows 
(* Effect on μ *)
   "map_mat of_int (inv_mu_ij_mat i j c) * M m =
    mat m m (λij. if ij = (i, j) then of_int c * d j else 0) + M m" (* only change value of μ_ij *)
(* Effect on A *)
  "A  carrier_mat m n  c mod p = 0  map_mat (λ x. x mod p) (inv_mu_ij_mat i j c * A) = 
    (map_mat (λ x. x mod p) A)" (* no change (mod p) *)
(* The transformation-matrix is ... *)
  "inv_mu_ij_mat i j c  carrier_mat m m" (* ... of dimension m*m *)
  "i' < j'  j' < m  inv_mu_ij_mat i j c $$ (i',j') = 0" (* ... lower triangular *)
  "k < m  inv_mu_ij_mat i j c $$ (k,k) = 1" (* ... with diagonal all 1 *)  
proof -
  obtain IM where IM: "IM = the (mat_inverse (M m))" by auto
  let ?oi = "of_int :: _  'a" 
  let ?C = "mat m m (λ ij. if ij = (i,j) then ?oi c else 0)" 
  let ?D = "mat m m (λ (i,j). d i * IM $$ (i,j))" 
  have oi: "inj ?oi" unfolding inj_on_def by auto
  have C: "?C  carrier_mat m m" by auto
  from i ji have j: "j < m" by auto
  from j have jm: "{0..<m} = {0..<j}  {j}  {Suc j..<m}" by auto
  note IM_props = d_inv_mu_integer[OF IM] inv_mu_inverse[OF IM]
  have mat_oi: "map_mat ?oi (inv_mu_ij_mat i j c) = ?C * ?D + 1m m" (is "?MM = _")
    unfolding inv_mu_ij_mat_def Let_def IM[symmetric]
    apply (subst of_int_hom.mat_hom_add, force, force)
    apply (rule arg_cong2[of _ _ _ _ "(+)"])
     apply (subst of_int_hom.mat_hom_mult, force, force)
     apply (rule arg_cong2[of _ _ _ _ "(*)"])
      apply force
     apply (rule eq_matI, (auto)[3], goal_cases)
  proof -
    case (1 i j)
    from IM_props(1)[OF 1]
    show ?case unfolding Ints_def using the_inv_f_f[OF oi] by auto
  qed auto
  have "map_mat ?oi (inv_mu_ij_mat i j c) * M m = (?C * ?D) * M m + M m" unfolding mat_oi
    by (subst add_mult_distrib_mat[of _ m m], auto)
  also have "(?C * ?D) * M m = ?C * (?D * M m)" 
    by (rule assoc_mult_mat, auto)
  also have "?D = mat m m (λ (i,j). if i = j then d j else 0) * IM" (is "_ = ?E * _")
  proof (rule eq_matI, insert IM_props(4), auto simp: scalar_prod_def, goal_cases)
    case (1 i j)
    hence id: "{0..<m} = {0..<i}  {i}  {Suc i ..<m}" 
      by (auto simp add: list_trisect)
    show ?case unfolding id
      by (auto simp: sum.union_disjoint)
  qed
  also have " * M m = ?E * (IM * M m)" 
    by (rule assoc_mult_mat[of _ m m], insert IM_props, auto)
  also have "IM * M m = 1m m" by fact
  also have "?E * 1m m = ?E" by simp
  also have "?C * ?E = mat m m (λ ij. if ij = (i,j) then ?oi c * d j else 0)" 
    by (rule eq_matI, auto simp: scalar_prod_def, auto simp: jm sum.union_disjoint)
  finally show "map_mat ?oi (inv_mu_ij_mat i j c) * M m = 
    mat m m (λ ij. if ij = (i,j) then ?oi c * d j else 0) + M m" .
  show carr: "inv_mu_ij_mat i j c  carrier_mat m m"
    unfolding inv_mu_ij_mat_def by auto
  {
    assume k: "k < m" 
    have "of_int (inv_mu_ij_mat i j c $$ (k,k)) = ?MM $$ (k,k)" 
      using carr k by auto
    also have " = (?C * ?D) $$ (k,k) + 1" unfolding mat_oi using k by simp
    also have "(?C * ?D) $$ (k,k) = 0" using k
      by (auto simp: scalar_prod_def, auto simp: jm sum.union_disjoint 
        inv_mu_lower_triangular[OF IM ji i])
    finally show "inv_mu_ij_mat i j c $$ (k,k) = 1" by simp
  }
  {
    assume ij': "i' < j'" "j' < m"  
    have "of_int (inv_mu_ij_mat i j c $$ (i',j')) = ?MM $$ (i',j')" 
      using carr ij' by auto
    also have " = (?C * ?D) $$ (i',j')" unfolding mat_oi using ij' by simp
    also have "(?C * ?D) $$ (i',j') = (if i' = i then ?oi c * (d j * IM $$ (j, j')) else 0)" 
      using ij' i j by (auto simp: scalar_prod_def, auto simp: jm sum.union_disjoint)
    also have " = 0" using inv_mu_lower_triangular[OF IM _ ij'(2), of j] ij' i ji by auto
    finally show "inv_mu_ij_mat i j c $$ (i',j') = 0" by simp
  }
  {
    assume A: "A  carrier_mat m n" and c: "c mod p = 0" 
    let ?mod = "map_mat (λ x. x mod p)" 
    let ?C = "mat m m (λ ij. if ij = (i,j) then c else 0)" 
    let ?D = "mat m m (λ ij. if ij = (i,j) then 1 else (0 :: int))" 
    define B where "B = mat m m (λ (i,j). the_inv ?oi (d i * the (mat_inverse (M m)) $$ (i,j)))" 
    have B: "B  carrier_mat m m" unfolding B_def by auto
    define BA where "BA = B * A" 
    have BA: "BA  carrier_mat m n" unfolding BA_def using A B by auto
    define DBA where "DBA = ?D * BA" 
    have DBA: "DBA  carrier_mat m n" unfolding DBA_def using BA by auto
    have "?mod (inv_mu_ij_mat i j c * A) = 
     ?mod ((?C * B + 1m m) * A)" 
      unfolding inv_mu_ij_mat_def B_def by simp
    also have "(?C * B + 1m m) * A = ?C * B * A + A" 
      by (subst add_mult_distrib_mat, insert A B, auto)
    also have "?C * B * A = ?C * BA" 
      unfolding BA_def
      by (rule assoc_mult_mat, insert A B, auto)
    also have "?C = c m ?D" 
      by (rule eq_matI, auto)
    also have " * BA = c m DBA" using BA unfolding DBA_def by auto
    also have "?mod ( + A) = ?mod A" 
      by (rule eq_matI, insert DBA A c, auto simp: mult.assoc) 
    finally show "?mod (inv_mu_ij_mat i j c * A) = ?mod A" .
  }
qed   
end
 
lemma Gramian_determinant_of_int: assumes fs: "set fs  carrier_vec n" 
  and j: "j  length fs" 
shows "of_int (gram_schmidt.Gramian_determinant n fs j)
  = gram_schmidt.Gramian_determinant n (map (map_vec rat_of_int) fs) j" 
proof -
  from j have j: "k < j  k < length fs" for k by auto
  show ?thesis
  unfolding gram_schmidt.Gramian_determinant_def
  by (subst of_int_hom.hom_det[symmetric], rule arg_cong[of _ _ det],
      unfold gram_schmidt.Gramian_matrix_def Let_def, subst of_int_hom.mat_hom_mult, force, force,
      unfold map_mat_transpose[symmetric],
      rule arg_cong2[of _ _ _ _ "λ x y. x * yT"], insert fs[unfolded set_conv_nth] 
      j, (fastforce intro!: eq_matI)+)
qed

context LLL
begin

(* this lemma might also be useful for swap/add-operation *)
lemma multiply_invertible_mat: assumes lin: "lin_indep fs" 
  and len: "length fs = m" 
  and A: "A  carrier_mat m m" 
  and A_invertible: " B. B  carrier_mat m m  B * A = 1m m" 
  and fs'_prod: "fs' = Matrix.rows (A * mat_of_rows n fs)" 
shows "lattice_of fs' = lattice_of fs" 
  "lin_indep fs'" 
  "length fs' = m" 
proof -
  let ?Mfs = "mat_of_rows n fs" 
  let ?Mfs' = "mat_of_rows n fs'" 
  from A_invertible obtain B where B: "B  carrier_mat m m" and inv: "B * A = 1m m" by auto
  from lin have fs: "set fs  carrier_vec n" unfolding gs.lin_indpt_list_def by auto
  with len have Mfs: "?Mfs  carrier_mat m n" by auto
  from A Mfs have prod: "A * ?Mfs  carrier_mat m n" by auto
  hence fs': "length fs' = m" "set fs'  carrier_vec n" unfolding fs'_prod
    by (auto simp: Matrix.rows_def Matrix.row_def)  
  have Mfs_prod': "?Mfs' = A * ?Mfs" 
    unfolding arg_cong[OF fs'_prod, of "mat_of_rows n"]
    by (intro eq_matI, auto simp: mat_of_rows_def)
  have "B * ?Mfs' = B * (A * ?Mfs)" 
    unfolding Mfs_prod' by simp
  also have " = (B * A) * ?Mfs"
    by (subst assoc_mult_mat[OF _ A Mfs], insert B, auto)
  also have "B * A = 1m m" by fact
  also have " * ?Mfs = ?Mfs" using Mfs by auto
  finally have Mfs_prod: "?Mfs = B * ?Mfs'" ..  
  interpret LLL: LLL_with_assms n m fs 2
    by (unfold_locales, auto simp: len lin)
  from LLL.LLL_change_basis[OF fs'(2,1) B A Mfs_prod Mfs_prod']
  show latt': "lattice_of fs' = lattice_of fs" and lin': "gs.lin_indpt_list (RAT fs')" 
    and len': "length fs' = m" 
    by (auto simp add: LLL_with_assms_def)
qed

text ‹This is the key lemma.›
lemma change_single_element: assumes lin: "lin_indep fs" 
  and len: "length fs = m" 
  and i: "i < m" and ji: "j < i"  
  and A: "A = gram_schmidt_fs_int.inv_mu_ij_mat n (RAT fs)"    ― ‹the transformation matrix A›
  and fs'_prod: "fs' = Matrix.rows (A i j c * mat_of_rows n fs)" ― ‹fs' is the new basis›
  and latt: "lattice_of fs = L" 
shows "lattice_of fs' = L"
  "c mod p = 0  map (map_vec (λ x. x mod p)) fs' = map (map_vec (λ x. x mod p)) fs" 
  "lin_indep fs'" 
  "length fs' = m" 
  " k. k < m  gso fs' k = gso fs k" 
  " k. k  m  d fs' k = d fs k" 
  "i' < m  j' < m  
    μ fs' i' j' = (if (i',j') = (i,j) then rat_of_int (c * d fs j) + μ fs i' j' else μ fs i' j')" 
  "i' < m  j' < m fs' i' j' = (if (i',j') = (i,j) then c * d fs j * d fs (Suc j) +fs i' j' elsefs i' j')" 
proof -
  let ?A = "A i j c" 
  let ?Mfs = "mat_of_rows n fs" 
  let ?Mfs' = "mat_of_rows n fs'" 
  from lin have fs: "set fs  carrier_vec n" unfolding gs.lin_indpt_list_def by auto
  with len have Mfs: "?Mfs  carrier_mat m n" by auto
  interpret gsi: gram_schmidt_fs_int n "RAT fs"
    rewrites "gsi.inv_mu_ij_mat = A" using lin unfolding A
    by (unfold_locales, insert lin[unfolded gs.lin_indpt_list_def], auto simp: set_conv_nth)
  note A = gsi.inv_mu_ij_mat[unfolded length_map len, OF i ji, where c = c]
  from A(3) Mfs have prod: "?A * ?Mfs  carrier_mat m n" by auto
  hence fs': "length fs' = m" "set fs'  carrier_vec n" unfolding fs'_prod
    by (auto simp: Matrix.rows_def Matrix.row_def)  
  have Mfs_prod': "?Mfs' = ?A * ?Mfs" 
    unfolding arg_cong[OF fs'_prod, of "mat_of_rows n"]
    by (intro eq_matI, auto simp: mat_of_rows_def)
  have detA: "det ?A = 1" 
    by (subst det_lower_triangular[OF A(4) A(3)], insert A, auto intro!: prod_list_neutral 
      simp: diag_mat_def)
  have " B. B  carrier_mat m m  B * ?A = 1m m" 
    by (intro exI[of _ "adj_mat ?A"], insert adj_mat[OF A(3)], auto simp: detA)
  from multiply_invertible_mat[OF lin len A(3) this fs'_prod] latt
  show latt': "lattice_of fs' = L" and lin': "gs.lin_indpt_list (RAT fs')" 
    and len': "length fs' = m" by auto
  interpret LLL: LLL_with_assms n m fs 2
    by (unfold_locales, auto simp: len lin)
  interpret fs: fs_int_indpt n fs
    by (standard, auto simp: lin)
  interpret fs': fs_int_indpt n fs'
    by (standard, auto simp: lin')
  {
    assume c: "c mod p = 0" 
    have id: "rows (map_mat f A) = map (map_vec f) (rows A)" for f A
      unfolding rows_def by auto
    have rows_id: "set fs  carrier_vec n  rows (mat_of_rows n fs) = fs" for fs
      unfolding mat_of_rows_def rows_def 
      by (force simp: Matrix.row_def set_conv_nth intro!: nth_equalityI)
    from A(2)[OF Mfs c]
    have "rows (map_mat (λx. x mod p) ?Mfs') = rows (map_mat (λx. x mod p) ?Mfs)" unfolding Mfs_prod'
      by simp
    from this[unfolded id rows_id[OF fs] rows_id[OF fs'(2)]]
    show "map (map_vec (λ x. x mod p)) fs' = map (map_vec (λ x. x mod p)) fs" .
  }
  {
    define B where "B = ?A" 
    have gs_eq: "k < m  gso fs' k = gso fs k" for k
    proof(induct rule: nat_less_induct)
      case (1 k)
      then show ?case 
      proof(cases "k = 0")
        case True
        then show ?thesis 
        proof -
          have "row ?Mfs' 0 = row ?Mfs 0"
          proof -
            have 2: "0 {0..<m}" and 3: "{1..<m} = {0..<m} - {0}" 
              and 4: "finite {0..<m}" using 1 by auto
            have "row ?Mfs' 0 = vec n (λj. row B 0  col ?Mfs j)" 
              using row_mult A(3) Mfs 1 Mfs_prod' unfolding B_def by simp
            also have " = vec n (λj. (l{0..<m}. B $$ (0, l) * ?Mfs $$ (l, j)))"
              using Mfs A(3) len 1 B_def unfolding scalar_prod_def by auto
            also have " = vec n (λj. B $$ (0, 0) * ?Mfs $$ (0, j) + 
              (l{1..<m}. B $$ (0, l) * ?Mfs $$ (l, j)))"
              using Groups_Big.comm_monoid_add_class.sum.remove[OF 4 2] 3
              by (simp add: g. sum g {0..<m} = g 0 + sum g ({0..<m} - {0}))
            also have " = row ?Mfs 0" 
              using A(4-) 1 unfolding B_def[symmetric] by (simp add: row_def)
            finally show ?thesis by (simp add: B_def Mfs_prod')
          qed
          then show ?thesis using True 1 fs'.f_carrier fs.f_carrier 
            fs'.gs.fs0_gso0 len' len gsi.fs0_gso0 by auto
        qed
      next
        case False
        then show ?thesis
        proof -
          have gso0kcarr: "gsi.gso ` {0 ..<k}  carrier_vec n"
            using 1(2) gsi.gso_carrier len by auto
          hence gsospancarr: "gs.span(gsi.gso ` {0 ..<k})  carrier_vec n " 
            using span_is_subset2 by auto

          have fs'_gs_diff_span: 
            "(RAT fs') !  k - fs'.gs.gso k  gs.span (gsi.gso ` {0 ..<k})"
          proof -
            define gs'sum where "gs'sum =
              gs.M.sumlist (map (λja. fs'.gs.μ k ja v fs'.gs.gso ja) [0..<k])"
            define gssum where "gssum = 
              gs.M.sumlist (map (λja. fs'.gs.μ k ja v gsi.gso ja) [0..<k])"
            have "set (map (λja. fs'.gs.μ k ja v gsi.gso ja) [0..<k]) 
               gs.span(gsi.gso ` {0 ..<k})" using 1(2) gs.span_mem gso0kcarr
              by auto
            hence gssumspan: "gssum  gs.span(gsi.gso ` {0 ..<k})"
              using atLeastLessThan_iff gso0kcarr imageE set_map set_upt 
                vec_space.sumlist_in_span 
              unfolding gssum_def by (smt subsetD)
            hence gssumcarr: "gssum  carrier_vec n" 
              using gsospancarr gssum_def by blast
            have sumid: "gs'sum = gssum"
            proof -
              have "map (λja. fs'.gs.μ k ja v fs'.gs.gso ja) [0..<k] =
                map (λja. fs'.gs.μ k ja v gsi.gso ja) [0..<k]"
                using 1 by simp
              thus ?thesis unfolding gs'sum_def gssum_def by argo
            qed
            have "(RAT fs') !  k = fs'.gs.gso k + gssum" 
              using fs'.gs.fs_by_gso_def len' False 1 sumid 
              unfolding gs'sum_def by auto
            hence "(RAT fs') !  k - fs'.gs.gso k = gssum" 
              using gssumcarr 1(2) len' by auto
            thus ?thesis using gssumspan by simp
          qed

          define v2 where "v2 = sumlist (map (λja. B $$ (k, ja) v fs ! ja) [0..< k])"
          have v2carr: "v2  carrier_vec n" 
          proof -
            have "set (map (λja. B $$ (k, ja) v fs ! ja) [0..< k])  carrier_vec n"
              using len 1(2) fs.f_carrier by auto
            thus ?thesis unfolding v2_def by simp
          qed
          define ratv2 where "ratv2 = (map_vec rat_of_int v2)"
          have ratv2carr: "ratv2  carrier_vec n" 
            unfolding ratv2_def using v2carr by simp
          have fs'id: "(RAT fs') ! k = (RAT fs) ! k + ratv2"
          proof -
            have zkm: "[0..<m] = [0..<(Suc k)] @ [(Suc k)..<m]" using 1(2) 
              by (metis Suc_lessI append_Nil2 upt_append upt_rec zero_less_Suc)
            have prep: "set (map (λja. B $$ (k, ja) v fs ! ja) [0..<m])  carrier_vec n" 
              using len fs.f_carrier by auto

            have "fs' ! k = vec n (λj. row B k  col ?Mfs j)"
              using 1(2) Mfs B_def A(3) fs'_prod by simp
            also have " = sumlist (map (λja. B $$ (k, ja) v fs ! ja) [0..<m])"
            proof -
              {
                fix i
                assume i: "i < n"
                have "(vec n (λj. row B k  col ?Mfs j)) $ i = row B k  col ?Mfs i" 
                  using i by auto
                also have " = (j = 0..<m. B $$ (k, j) * ?Mfs $$ (j,i))" 
                  using A(3) unfolding B_def[symmetric] 
                  by (smt 1(2) Mfs R.finsum_cong' i atLeastLessThan_iff carrier_matD
                      dim_col index_col index_row(1) scalar_prod_def)
                also have " = (j = 0..<m. B $$ (k, j) * (fs ! j $ i))"
                  by (metis (no_types, lifting) R.finsum_cong' atLeastLessThan_iff i
                      len mat_of_rows_index)
                also have " = 
                  (j = 0..<m. (map (λja.  B $$ (k, ja) v fs ! ja) [0..<m]) ! j $ i)"
                proof -
                  have "j<m. i<n. B $$ (k, j) * (fs ! j $ i) = 
                    (map (λja.  B $$ (k, ja) v fs ! ja) [0..<m]) ! j $ i" 
                    using 1(2) i A(3) len fs.f_carrier
                    unfolding B_def[symmetric] by auto
                  then show ?thesis using i by auto
                qed
                also have " = sumlist (map (λja. B $$ (k, ja) v fs ! ja) [0..<m]) $ i"
                  using sumlist_nth i fs.f_carrier carrier_vecD len by simp
                finally have "(vec n (λj. row B k  col ?Mfs j)) $ i =
                  sumlist (map (λja. B $$ (k, ja) v fs ! ja) [0..<m]) $ i" by auto
              }
              then show ?thesis using fs.f_carrier len dim_sumlist by auto
            qed
            also have " = sumlist (map (λja. B $$ (k, ja) v fs ! ja) 
              ([0..<(Suc k)] @ [(Suc k)..<m]))" 
              using zkm by simp
            also have " = sumlist (map (λja. B $$ (k, ja) v fs ! ja) [0..<(Suc k)]) +
              sumlist (map (λja. B $$ (k, ja) v fs ! ja) [(Suc k)..<m])"
              (is " = ?L2 + ?L3")
              using fs.f_carrier len dim_sumlist sumlist_append prep zkm by auto
            also have "?L3 = 0v n"
              using A(4) fs.f_carrier len sumlist_nth carrier_vecD sumlist_carrier 
                prep zkm unfolding B_def[symmetric] by auto
            also have "?L2 = sumlist (map (λja. B $$ (k, ja) v fs ! ja) [0..<k]) +
              B $$ (k, k) v fs ! k" using prep zkm sumlist_snoc by simp
            also have " = sumlist (map (λja. B $$ (k, ja) v fs ! ja) [0..<k]) + fs ! k"
              using A(5) 1(2) unfolding B_def[symmetric] by simp
            finally have "fs' ! k = fs ! k + 
              sumlist (map (λja. B $$ (k, ja) v fs ! ja) [0..<k])"
              using prep zkm by (simp add: M.add.m_comm)
            then have "fs' !  k = fs !  k + v2" unfolding v2_def by simp
            then show ?thesis using v2carr 1(2) len len' ratv2_def by force
          qed
          have ratv2span: "ratv2  gs.span (gsi.gso ` {0 ..<k})" 
          proof -
            have rat: "ratv2 = gs.M.sumlist
              (map (λj. of_int (B $$ (k, j)) v (RAT fs) ! j) [0..<k])"
            proof -
              have "set (map (λj. of_int (B $$ (k, j)) v (RAT fs) ! j) [0..<k]) 
                 carrier_vec n"
                using fs.f_carrier 1(2) len by auto
              hence carr: "gs.M.sumlist 
                (map (λj. of_int (B $$ (k, j)) v (RAT fs) ! j) [0..<k])  carrier_vec n"
                by auto
              have "set (map (λj. B $$ (k, j) v fs ! j) [0..<k])  carrier_vec n"
                using fs.f_carrier 1(2) len by auto
              hence "i j. i < n  j < k  of_int ((B $$ (k, j) v fs ! j) $ i)
                = (of_int (B $$ (k, j)) v (RAT fs) ! j) $ i"
                using 1(2) len by fastforce
              hence "i. i < n  ratv2 $ i = gs.M.sumlist
                (map (λj. (of_int (B $$ (k, j)) v (RAT fs) ! j)) [0..<k]) $ i"
                using fs.f_carrier 1(2) len v2carr gs.sumlist_nth sumlist_nth 
                  ratv2_def v2_def by simp
              then show ?thesis using ratv2carr carr by auto
            qed
            have "i. i < k  (RAT fs) ! i = 
              gs.M.sumlist (map (λ j. gsi.μ i j v gsi.gso j) [0 ..< Suc i])"
              using gsi.fi_is_sum_of_mu_gso len 1(2) by auto
            moreover have "i. i < k  (λ j. gsi.μ i j v gsi.gso j) ` {0 ..< Suc i}
               gs.span (gsi.gso ` {0 ..<k})"
              using gs.span_mem gso0kcarr by auto
            ultimately have "i. i < k  (RAT fs) ! i  gs.span (gsi.gso ` {0 ..<k})"
              using gso0kcarr set_map set_upt vec_space.sumlist_in_span subsetD by smt
            then show ?thesis using rat atLeastLessThan_iff set_upt gso0kcarr imageE 
              set_map gs.smult_in_span vec_space.sumlist_in_span by smt
          qed
          have fs_gs_diff_span:
            "(RAT fs) !  k - fs'.gs.gso k  gs.span (gsi.gso ` {0 ..<k})"
          proof -
            from fs'_gs_diff_span obtain v3 where sp: "v3  gs.span (gsi.gso ` {0 ..<k})"
              and eq: "(RAT fs) ! k - fs'.gs.gso k = v3 - ratv2" 
              using fs'.gs.gso_carrier len' 1(2) ratv2carr fs'id by fastforce
            have "v3+(-ratv2)  gs.span(gsi.gso ` {0 ..<k})"
              by (metis sp gs.span_add1 gso0kcarr gram_schmidt.inv_in_span 
                  gso0kcarr ratv2span)
            moreover have "v3+(-ratv2) = v3-ratv2" using ratv2carr by auto
            ultimately have "v3 - ratv2  gs.span (gsi.gso ` {0 ..<k})" by simp
            then show ?thesis using eq by auto
          qed
          {
            fix i
            assume i: "i < k"
            hence "fs'.gs.gso k  fs'.gs.gso i = 0" using 1(2) fs'.gs.orthogonal len' by auto
            hence "fs'.gs.gso k  gsi.gso i = 0" using 1 i by simp
          }
          hence "x. x  gsi.gso ` {0..<k}  fs'.gs.gso k  x = 0" by auto

          then show ?thesis
            using gsi.oc_projection_unique len len' fs_gs_diff_span 1(2) by auto
        qed
      qed
    qed

    have " i' j'. i' < m  j' < m  μ fs' i' j' = 
      (map_mat of_int (A i j c) * gsi.M m) $$ (i',j')" and
      " k. k < m  gso fs' k = gso fs k"
    proof -
      define rB where "rB = map_mat rat_of_int B"
      have rBcarr: "rB  carrier_mat m m" using A(3) unfolding rB_def B_def by simp
      define rfs where "rfs = mat_of_rows n (RAT fs)"
      have rfscarr: "rfs  carrier_mat m n" using Mfs unfolding rfs_def by simp

      {
        fix i'
        fix j'
        assume i': "i' < m"
        assume j': "j' < m"
        have prep: 
          "of_int_hom.vec_hom (row (B * mat_of_rows n fs) i') = row (rB * rfs) i'" 
          using len i' B_def A(3) rB_def rfs_def by (auto simp: scalar_prod_def)
        have prep2: "row (rB * rfs) i' = vec n (λl. row rB i'  col rfs l)"
          using len fs.f_carrier i' B_def A(3) scalar_prod_def rB_def
          unfolding rfs_def by auto
        have prep3: "(vec m (λ j1. row rfs j1  gsi.gso j' / gsi.gso j'2)) =
          (vec m (λ j1. (gsi.M m) $$ (j1, j')))"
        proof -
          {
            fix x y
            assume x: "x < m" and y: "y < m"
            have "(gsi.M m) $$ (x,y) = (if y < x then map of_int_hom.vec_hom fs ! x 
               fs'.gs.gso y / fs'.gs.gso y2 else if x = y then 1 else 0)" 
              using gsi.μ.simps x y j' len gs_eq gsi.M_index by auto
            hence "row rfs x  gsi.gso y / gsi.gso y2 = (gsi.M m) $$ (x,y)"
              unfolding rfs_def 
              by (metis carrier_matD(1) divide_eq_eq fs'.gs.β_zero fs'.gs.gso_norm_beta 
                  gs_eq gsi.μ.simps gsi.fi_scalar_prod_gso gsi.fs_carrier len len' 
                  length_map nth_rows rfs_def rfscarr rows_mat_of_rows x y)
          }
          then show ?thesis using j' by auto
        qed
        have prep4: "(1 / gsi.gso j'2) v (vec m (λj1. row rfs j1  gsi.gso j')) =
          (vec m (λj1. row rfs j1  gsi.gso j' / gsi.gso j'2))" by auto

        have "map of_int_hom.vec_hom fs' ! i'  fs'.gs.gso j' / fs'.gs.gso j'2
           = map of_int_hom.vec_hom fs' ! i'  gsi.gso j' / gsi.gso j'2"
          using gs_eq j' by simp
        also have " = row (rB * rfs) i'  gsi.gso j' / gsi.gso j'2"
          using prep i' len' unfolding rB_def B_def by (simp add: fs'_prod)
        also have " = 
          (vec n (λl. row rB i'  col rfs l))  gsi.gso j' / gsi.gso j'2"
          using prep2 by auto
        also have "vec n (λl. row rB i'  col rfs l) = 
            (vec n (λl. (j1=0..<m. (row rB i') $ j1 * (col rfs l) $ j1)))"
          using gsi.gso_carrier
          by (metis (no_types) carrier_matD(1) col_def dim_vec rfscarr scalar_prod_def)
        also have " = 
            (vec n (λl. (j1=0..<m. rB $$ (i', j1) * rfs $$ (j1, l))))" 
          using rBcarr rfscarr i' by auto
        also have "  gsi.gso j' = 
            (j2=0..<n. (vec n 
            (λl. (j1=0..<m. rB $$ (i', j1) * rfs $$ (j1, l)))) $ j2 * (gsi.gso j') $ j2)"
          using gsi.gso_carrier len j' scalar_prod_def 
          by (smt gs.R.finsum_cong' gsi.gso_dim length_map)
        also have " = (j2=0..<n.
            (j1=0..<m. rB $$ (i', j1) * rfs $$ (j1, j2)) * (gsi.gso j') $ j2)"
          using gsi.gso_carrier len j' by simp
        also have " = (j2=0..<n. (j1=0..<m.
            rB $$ (i', j1) * rfs $$ (j1, j2) * (gsi.gso j') $ j2))" 
          by (smt gs.R.finsum_cong' sum_distrib_right)
        also have " = (j1=0..<m. (j2=0..<n.
            rB $$ (i', j1) * rfs $$ (j1, j2) * (gsi.gso j') $ j2))"
          using sum.swap by auto
        also have " = (j1=0..<m. rB $$ (i', j1) * (j2=0..<n. 
            rfs $$ (j1, j2) * (gsi.gso j') $ j2))"
          using gs.R.finsum_cong' sum_distrib_left by (smt gs.m_assoc)
        also have " = row rB i'  (vec m (λ j1. (j2=0..<n.
            rfs $$ (j1, j2) * (gsi.gso j') $ j2)))" 
          using rBcarr rfscarr i' scalar_prod_def
          by (smt atLeastLessThan_iff carrier_matD(1) carrier_matD(2) dim_vec 
              gs.R.finsum_cong' index_row(1) index_vec)
        also have "(vec m (λ j1. (j2=0..<n. rfs $$ (j1, j2) * (gsi.gso j') $ j2)))
            =  (vec m (λ j1. row rfs j1  gsi.gso j'))"
          using rfscarr gsi.gso_carrier len j' rfscarr by (auto simp add: scalar_prod_def)
        also have "row rB i'   / gsi.gso j'2 =
          row rB i'  vec m (λ j1. row rfs j1  gsi.gso j' / gsi.gso j'2)"
          using prep4 scalar_prod_smult_right rBcarr carrier_matD(2) dim_vec row_def 
          by (smt gs.l_one times_divide_eq_left)
        also have " = (rB * (gsi.M m)) $$ (i', j')" 
          using rBcarr i' j' prep3 gsi.M_def by (simp add: col_def)
        finally have 
          "map of_int_hom.vec_hom fs' ! i'  fs'.gs.gso j' / fs'.gs.gso j'2 =
          (rB * (gsi.M m)) $$ (i', j')" by auto
      }
      then show " i' j'. i' < m  j' < m  μ fs' i' j' = 
        (map_mat of_int (A i j c) * gsi.M m) $$ (i',j')" 
        using B_def fs'.gs.β_zero fs'.gs.fi_scalar_prod_gso fs'.gs.gso_norm_beta
          len' rB_def by auto
      show " k. k < m  gso fs' k = gso fs k" using gs_eq by auto
    qed
  } note mu_gso = this

  show " k. k < m  gso fs' k = gso fs k" by fact
  {
    fix k
    have "k  m  rat_of_int (d fs' k) = rat_of_int (d fs k)" for k
    proof (induct k)
      case 0
      show ?case by (simp add: d_def)
    next
      case (Suc k)
      hence k: "k  m" "k < m" by auto 
      show ?case
        by (subst (1 2) LLL_d_Suc[OF _ k(2)], auto simp: Suc(1)[OF k(1)] mu_gso(2)[OF k(2)]
          LLL_invariant_weak_def lin lin' len len' latt latt')
    qed
    thus "k  m  d fs' k = d fs k" by simp
  } note d = this
  {
    assume i': "i' < m" and j': "j' < m"
    have fs' i' j' = (of_int_hom.mat_hom (A i j c) * gsi.M m) $$ (i',j')" by (rule mu_gso(1)[OF i' j'])
    also have " = (if (i',j') = (i,j) then of_int c * gsi.d j else 0) + gsi.M m $$ (i',j')" 
      unfolding A(1) using i' j' by (auto simp: gsi.M_def)
    also have "gsi.M m $$ (i',j') = μ fs i' j'" 
      unfolding gsi.M_def using i' j' by simp
    also have "gsi.d j = of_int (d fs j)" 
      unfolding d_def by (subst Gramian_determinant_of_int[OF fs], insert ji i len, auto)
    finally show mu: fs' i' j' = (if (i',j') = (i,j) then rat_of_int (c * d fs j) + μ fs i' j' else μ fs i' j')" 
      by simp
    let ?d = "d fs (Suc j')" 
    have d_fs: "of_int (fs i' j') = rat_of_int ?d * μ fs i' j'" 
      unfolding dμ_def 
      using fs.fs_int_mu_d_Z_m_m[unfolded len, OF i' j'] 
      by (metis LLL.LLL.d_def assms(2) fs.fs_int_mu_d_Z_m_m fs_int.d_def i' 
          int_of_rat(2) j')
    have "rat_of_int (fs' i' j') = rat_of_int (d fs' (Suc j')) * μ fs' i' j'" 
      unfolding dμ_def 
      using fs'.fs_int_mu_d_Z_m_m[unfolded len', OF i' j']
      using LLL.LLL.d_def fs'(1) fs'.dμ fs'.dμ_def fs_int.d_def i' j' by auto
    also have "d fs' (Suc j') = ?d" by (rule d, insert j', auto)
    also have "rat_of_int  * μ fs' i' j' = 
      (if (i',j') = (i,j) then rat_of_int (c * d fs j * ?d) else 0) + of_int (fs i' j')" 
      unfolding mu d_fs by (simp add: field_simps)
    also have " = rat_of_int ((if (i',j') = (i,j) then c * d fs j * ?d else 0) +fs i' j')"
      by simp
    also have " = rat_of_int ((if (i',j') = (i,j) then c * d fs j * d fs (Suc j) +fs i' j' elsefs i' j'))"
      by simp
    finally show "dμ fs' i' j' = (if (i',j') = (i,j) then c * d fs j * d fs (Suc j) +fs i' j' elsefs i' j')" 
      by simp
  }
qed

text ‹Eventually: Lemma 13 of Storjohann's paper.›
lemma mod_single_element: assumes lin: "lin_indep fs" 
  and len: "length fs = m" 
  and i: "i < m" and ji: "j < i"  
  and latt: "lattice_of fs = L" 
  and pgtz: "p > 0"
shows " fs'. lattice_of fs' = L  
  map (map_vec (λ x. x mod p)) fs' = map (map_vec (λ x. x mod p)) fs 
  map (map_vec (λ x. x symmod p)) fs' = map (map_vec (λ x. x symmod p)) fs 
  lin_indep fs' 
  length fs' = m  
  ( k < m. gso fs' k = gso fs k)  
  ( k  m. d fs' k = d fs k) 
  ( i' < m.  j' < m.fs' i' j' = (if (i',j') = (i,j) thenfs i j' symmod (p * d fs j' * d fs (Suc j')) elsefs i' j'))" 
proof -
  have inv: "LLL_invariant_weak fs" using LLL_invariant_weak_def assms by simp
  let ?mult = "d fs j * d fs (Suc j)" 
  define M where "M = ?mult" 
  define pM where "pM = p * M" 
  then have pMgtz: "pM > 0" using pgtz unfolding pM_def M_def using LLL_d_pos[OF inv] i ji by simp
  let ?d = "dμ fs i j" 
  define c where "c = - (?d symdiv pM)" 
  have d_mod: "?d symmod pM = c * pM + ?d" unfolding c_def using pMgtz sym_mod_sym_div by simp
  define A where "A = gram_schmidt_fs_int.inv_mu_ij_mat n (RAT fs)" 
  define fs' where fs': "fs' = Matrix.rows (A i j (c * p) * mat_of_rows n fs)"
  note main = change_single_element[OF lin len i ji A_def fs' latt]
  have "map (map_vec (λx. x mod p)) fs' = map (map_vec (λx. x mod p)) fs" 
    by (intro main, auto)
  from arg_cong[OF this, of "map (map_vec (poly_mod.inv_M p))"]
  have id: "map (map_vec (λx. x symmod p)) fs' = map (map_vec (λx. x symmod p)) fs" 
    unfolding map_map o_def sym_mod_def map_vec_map_vec .
  show ?thesis
  proof (intro exI[of _ fs'] conjI main allI impI id)
    fix i' j'
    assume ij: "i' < m" "j' < m" 
    have "dμ fs' i' j' = (if (i', j') = (i, j) then (c * p) * M + ?d elsefs i' j')" 
      unfolding main(8)[OF ij] M_def by simp
    also have "(c * p) * M + ?d = ?d symmod pM" 
      unfolding d_mod by (simp add: pM_def)
    finally show "dμ fs' i' j' = (if (i',j') = (i,j) thenfs i j' symmod (p * d fs j' * d fs (Suc j')) elsefs i' j')" 
      by (auto simp: pM_def M_def ac_simps)
  qed auto
qed 

text ‹A slight generalization to perform modulo on arbitrary set of indices $I$.›
lemma mod_finite_set: assumes lin: "lin_indep fs" 
  and len: "length fs = m" 
  and I: "I  {(i,j). i < m  j < i}"
  and latt: "lattice_of fs = L" 
  and pgtz: "p > 0"
shows " fs'. lattice_of fs' = L 
  map (map_vec (λ x. x mod p)) fs' = map (map_vec (λ x. x mod p)) fs 
  map (map_vec (λ x. x symmod p)) fs' = map (map_vec (λ x. x symmod p)) fs 
  lin_indep fs' 
  length fs' = m  
  ( k < m. gso fs' k = gso fs k)  
  ( k  m. d fs' k = d fs k) 
  ( i' < m.  j' < m.fs' i' j' = 
     (if (i',j')  I thenfs i' j' symmod (p * d fs j' * d fs (Suc j')) elsefs i' j'))"
proof -
  let ?exp = "λ fs' I i' j'.fs' i' j' = (if (i',j')  I thenfs i' j' symmod (p * d fs j' * d fs (Suc j')) elsefs i' j')" 
  let ?prop = "λ fs fs'. lattice_of fs' = L  
    map (map_vec (λ x. x mod p)) fs' = map (map_vec (λ x. x mod p)) fs 
    map (map_vec (λ x. x symmod p)) fs' = map (map_vec (λ x. x symmod p)) fs 
    lin_indep fs' 
    length fs' = m  
    ( k < m. gso fs' k = gso fs k)  
    ( k  m. d fs' k = d fs k)" 
  have "finite I" 
  proof (rule finite_subset[OF I], rule finite_subset)
    show "{(i, j). i < m  j < i}  {0..m} × {0..m}" by auto
  qed auto
  from this I have " fs'. ?prop fs fs'  ( i' < m.  j' < m. ?exp fs' I i' j')"
  proof (induct I)
    case empty
    show ?case
      by (intro exI[of _ fs], insert assms, auto)
  next
    case (insert ij I)
    obtain i j where ij: "ij = (i,j)" by force
    from ij insert(4) have i: "i < m" "j < i" by auto
    from insert(3,4) obtain gs where gs: "?prop fs gs" 
      and exp: " i' j'. i' < m  j' < m  ?exp gs I i' j'" by auto
    from gs have "lin_indep gs" "lattice_of gs = L" "length gs = m" by auto
    from mod_single_element[OF this(1,3) i this(2), of p] 
    obtain hs where hs: "?prop gs hs" 
      and exp': " i' j'. i' < m  j' < m hs i' j' = (if (i', j') = (i, j) 
         thengs i j' symmod (p * d gs j' * d gs (Suc j')) elsegs i' j')" 
      using pgtz by auto
    from gs i have id: "d gs j = d fs j" "d gs (Suc j) = d fs (Suc j)" by auto
    show ?case 
    proof (intro exI[of _ hs], rule conjI; (intro allI impI)?)
      show "?prop fs hs" using gs hs by auto
      fix i' j'
      assume *: "i' < m" "j' < m" 
      show "?exp hs (insert ij I) i' j'" unfolding exp'[OF *] ij using exp * i
        by (auto simp: id)
    qed
  qed
  thus ?thesis by auto
qed

end

end

Theory Storjohann

section ‹Storjohann's basis reduction algorithm (abstract version)›

text ‹This theory contains the soundness proofs of Storjohann's basis
  reduction algorithms, both for the normal and the improved-swap-order variant.

  The implementation of Storjohann's version of LLL uses modular operations throughout.
  It is an abstract implementation that is already quite close to what the actual implementation will be.
   In particular, the swap operation here is derived from the computation lemma for the swap
   operation in the old, integer-only formalization of LLL.›

theory Storjohann
  imports 
    Storjohann_Mod_Operation
    LLL_Basis_Reduction.LLL_Number_Bounds
    Sqrt_Babylonian.NthRoot_Impl
begin

subsection ‹Definition of algorithm›

text ‹In the definition of the algorithm, the first-flag determines, whether only the first vector
  of the reduced basis should be computed, i.e., a short vector. Then the modulus can be slightly
  decreased in comparison to the required modulus for computing the whole reduced matrix.›

fun max_list_rats_with_index :: "(int * int * nat) list  (int * int * nat)" where
  "max_list_rats_with_index [x] = x" |
  "max_list_rats_with_index ((n1,d1,i1) # (n2,d2,i2) # xs) 
     = max_list_rats_with_index ((if n1 * d2  n2 * d1 then (n2,d2,i2) else (n1,d1,i1)) # xs)"

context LLL
begin

definition "log_base = (10 :: int)" 

definition bound_number :: "bool  nat" where
  "bound_number first = (if first  m  0 then 1 else m)" 

definition compute_mod_of_max_gso_norm :: "bool  rat  int" where
  "compute_mod_of_max_gso_norm first mn = log_base ^ (log_ceiling log_base (max 2 (
     root_rat_ceiling 2 (mn * (rat_of_nat (bound_number first) + 3)) + 1)))"

definition g_bnd_mode :: "bool  rat  int vec list  bool" where 
  "g_bnd_mode first b fs = (if first  m  0 then sq_norm (gso fs 0)  b else g_bnd b fs)" 

definition d_of where "d_of dmu i = (if i = 0 then 1 :: int else dmu $$ (i - 1, i - 1))"

definition compute_max_gso_norm :: "bool  int mat  rat × nat" where
  "compute_max_gso_norm first dmu = (if m = 0 then (0,0) else 
      case max_list_rats_with_index (map (λ i. (d_of dmu (Suc i), d_of dmu i, i)) [0 ..< (if first then 1 else m)])
      of (num, denom, i)  (of_int num / of_int denom, i))"


context
  fixes p :: int ― ‹the modulus›
    and first :: bool ― ‹only compute first vector of reduced basis›
begin

definition basis_reduction_mod_add_row :: 
  "int vec list  int mat  nat  nat  (int vec list × int mat)"  where
  "basis_reduction_mod_add_row mfs dmu i j = 
    (let c = round_num_denom (dmu $$ (i,j)) (d_of dmu (Suc j)) in
      (if c = 0 then (mfs, dmu) 
        else (mfs[ i := (map_vec (λ x. x symmod p)) (mfs ! i - c v mfs ! j)], 
             mat m m (λ(i',j'). (if (i' = i  j'  j) 
                then (if j'=j then (dmu $$ (i,j') - c * dmu $$ (j,j')) 
                      else (dmu $$ (i,j') - c * dmu $$ (j,j')) 
                            symmod (p * d_of dmu j' * d_of dmu (Suc j')))
                else (dmu $$ (i',j')))))))"

fun basis_reduction_mod_add_rows_loop where
  "basis_reduction_mod_add_rows_loop mfs dmu i 0 = (mfs, dmu)"
| "basis_reduction_mod_add_rows_loop mfs dmu i (Suc j) = (
     let (mfs', dmu') = basis_reduction_mod_add_row mfs dmu i j
      in basis_reduction_mod_add_rows_loop mfs' dmu' i j)" 

definition basis_reduction_mod_swap_dmu_mod :: "int mat  nat  int mat" where
  "basis_reduction_mod_swap_dmu_mod dmu k = mat m m (λ(i, j). (
    if j < i  (j = k  j = k - 1) then 
        dmu $$ (i, j) symmod (p * d_of dmu j * d_of dmu (Suc j))
    else dmu $$ (i, j)))"

definition basis_reduction_mod_swap where
  "basis_reduction_mod_swap mfs dmu k = 
     (mfs[k := mfs ! (k - 1), k - 1 := mfs ! k],
      basis_reduction_mod_swap_dmu_mod (mat m m (λ(i,j). (
      if j < i then
        if i = k - 1 then 
           dmu $$ (k, j)
        else if i = k  j  k - 1 then 
             dmu $$ (k - 1, j)
        else if i > k  j = k then
           ((d_of dmu (Suc k)) * dmu $$ (i, k - 1) - dmu $$ (k, k - 1) * dmu $$ (i, j)) 
              div (d_of dmu k)
        else if i > k  j = k - 1 then
           (dmu $$ (k, k - 1) * dmu $$ (i, j) + dmu $$ (i, k) * (d_of dmu (k-1)))
              div (d_of dmu k)
        else dmu $$ (i, j)
      else if i = j then 
        if i = k - 1 then 
          ((d_of dmu (Suc k)) * (d_of dmu (k-1)) + dmu $$ (k, k - 1) * dmu $$ (k, k - 1)) 
            div (d_of dmu k)
        else (d_of dmu (Suc i))
      else dmu $$ (i, j))
    )) k)" 

fun basis_reduction_adjust_mod where
  "basis_reduction_adjust_mod mfs dmu = 
    (let (b,g_idx) = compute_max_gso_norm first dmu;
         p' = compute_mod_of_max_gso_norm first b
        in if p' < p then 
           let mfs' = map (map_vec (λx. x symmod p')) mfs;
               d_vec = vec (Suc m) (λ i. d_of dmu i);
               dmu' = mat m m (λ (i,j). if j < i then dmu $$ (i,j) 
                 symmod (p' * d_vec $ j * d_vec $ (Suc j)) else
                 dmu $$ (i,j))
             in (p', mfs', dmu', g_idx)
           else (p, mfs, dmu, g_idx))" 

definition basis_reduction_adjust_swap_add_step where
  "basis_reduction_adjust_swap_add_step mfs dmu g_idx i = (
    let i1 = i - 1; 
        (mfs1, dmu1) = basis_reduction_mod_add_row mfs dmu i i1;
        (mfs2, dmu2) = basis_reduction_mod_swap mfs1 dmu1 i
      in if i1 = g_idx then basis_reduction_adjust_mod mfs2 dmu2
         else (p, mfs2, dmu2, g_idx))"


definition basis_reduction_mod_step where
  "basis_reduction_mod_step mfs dmu g_idx i (j :: int) = (if i = 0 then (p, mfs, dmu, g_idx, Suc i, j)
     else let di = d_of dmu i;
              (num, denom) = quotient_of α
      in if di * di * denom  num * d_of dmu (i - 1) * d_of dmu (Suc i) then
          (p, mfs, dmu, g_idx, Suc i, j)
      else let (p', mfs', dmu', g_idx') = basis_reduction_adjust_swap_add_step mfs dmu g_idx i
          in (p', mfs', dmu', g_idx', i - 1, j + 1))" 

primrec basis_reduction_mod_add_rows_outer_loop where
  "basis_reduction_mod_add_rows_outer_loop mfs dmu 0 = (mfs, dmu)" |
  "basis_reduction_mod_add_rows_outer_loop mfs dmu (Suc i) = 
    (let (mfs', dmu') = basis_reduction_mod_add_rows_outer_loop mfs dmu i in
      basis_reduction_mod_add_rows_loop mfs' dmu' (Suc i) (Suc i))"
end

text ‹the main loop of the normal Storjohann algorithm›
partial_function (tailrec) basis_reduction_mod_main where
  "basis_reduction_mod_main p first mfs dmu g_idx i (j :: int) = (
    (if i < m 
       then 
         case basis_reduction_mod_step p first mfs dmu g_idx i j
         of (p', mfs', dmu', g_idx', i', j')   
           basis_reduction_mod_main p' first mfs' dmu' g_idx' i' j'
       else
         (p, mfs, dmu)))"

definition compute_max_gso_quot:: "int mat  (int * int * nat)" where
  "compute_max_gso_quot dmu = max_list_rats_with_index 
    (map (λi. ((d_of dmu (i+1)) * (d_of dmu (i+1)), (d_of dmu (i+2)) * (d_of dmu i), Suc i)) [0..<(m-1)])"

text ‹the main loop of Storjohann's algorithm with improved swap order›
partial_function (tailrec) basis_reduction_iso_main where
  "basis_reduction_iso_main p first mfs dmu g_idx (j :: int) = (
    (if m > 1 then
      (let (max_gso_num, max_gso_denum, indx) = compute_max_gso_quot dmu;
        (num, denum) = quotient_of α in
        (if (max_gso_num * denum  > num * max_gso_denum) then
            case basis_reduction_adjust_swap_add_step p first mfs dmu g_idx indx of
              (p', mfs', dmu', g_idx') 
          basis_reduction_iso_main p' first mfs' dmu' g_idx' (j + 1) 
         else
           (p, mfs, dmu)))
     else (p, mfs, dmu)))"

definition compute_initial_mfs where
  "compute_initial_mfs p = map (map_vec (λx. x symmod p)) fs_init"

definition compute_initial_dmu where
  "compute_initial_dmu p dmu = mat m m (λ(i',j'). if j' < i' 
        then dmu $$ (i', j') symmod (p * d_of dmu j' * d_of dmu (Suc j')) 
        else dmu $$ (i', j'))"

definition "dmu_initial = (let dmu = dμ_impl fs_init
   in mat m m (λ (i,j). 
   if j  i then dμ_impl fs_init !! i !! j else 0))"

definition "compute_initial_state first = 
  (let dmu = dmu_initial;
       (b, g_idx) = compute_max_gso_norm first dmu;
       p = compute_mod_of_max_gso_norm first b
     in (p, compute_initial_mfs p, compute_initial_dmu p dmu, g_idx))" 

text ‹Storjohann's algorithm›
definition reduce_basis_mod :: "int vec list" where
  "reduce_basis_mod = (
     let first = False;
         (p0, mfs0, dmu0, g_idx) = compute_initial_state first;
         (p', mfs', dmu') = basis_reduction_mod_main p0 first mfs0 dmu0 g_idx 0 0;
         (mfs'', dmu'') = basis_reduction_mod_add_rows_outer_loop p' mfs' dmu' (m-1)
      in mfs'')"

text ‹Storjohann's algorithm with improved swap order›
definition reduce_basis_iso :: "int vec list" where
  "reduce_basis_iso = (
     let first = False; 
         (p0, mfs0, dmu0, g_idx) = compute_initial_state first;
         (p', mfs', dmu') = basis_reduction_iso_main p0 first mfs0 dmu0 g_idx 0;
         (mfs'', dmu'') = basis_reduction_mod_add_rows_outer_loop p' mfs' dmu' (m-1)
      in mfs'')"

text ‹Storjohann's algorithm for computing a short vector›
definition 
  "short_vector_mod = (
     let first = True;
         (p0, mfs0, dmu0, g_idx) = compute_initial_state first;
         (p', mfs', dmu') = basis_reduction_mod_main p0 first mfs0 dmu0 g_idx 0 0
      in hd mfs')"

text ‹Storjohann's algorithm (iso-variant) for computing a short vector›
definition 
  "short_vector_iso = (
     let first = True; 
         (p0, mfs0, dmu0, g_idx) = compute_initial_state first;
         (p', mfs', dmu') = basis_reduction_iso_main p0 first mfs0 dmu0 g_idx 0
      in hd mfs')"
end

subsection ‹Towards soundness of Storjohann's algorithm›

lemma max_list_rats_with_index_in_set: 
  assumes max: "max_list_rats_with_index xs = (nm, dm, im)"
  and len: "length xs  1"
shows "(nm, dm, im)  set xs"
  using assms
proof (induct xs rule: max_list_rats_with_index.induct)
  case (2 n1 d1 i1 n2 d2 i2 xs)
  have "1  length ((if n1 * d2  n2 * d1 then (n2, d2, i2) else (n1, d1, i1)) # xs)" by simp
  moreover have "max_list_rats_with_index ((if n1 * d2  n2 * d1 then (n2, d2, i2) else (n1, d1, i1)) # xs)
              = (nm, dm, im)" using 2 by simp
  moreover have "(if n1 * d2  n2 * d1 then (n2, d2, i2) else (n1, d1, i1)) 
        set ((n1, d1, i1) # (n2, d2, i2) # xs)" by simp
  moreover then have "set ((if n1 * d2  n2 * d1 then (n2, d2, i2) else (n1, d1, i1)) # xs) 
        set ((n1, d1, i1) # (n2, d2, i2) # xs)" by auto
  ultimately show ?case using 2(1) by auto
qed auto

lemma max_list_rats_with_index: assumes " n d i. (n,d,i)  set xs  d > 0" 
  and max: "max_list_rats_with_index xs = (nm, dm, im)" 
  and "(n,d,i)  set xs" 
shows "rat_of_int n / of_int d  of_int nm / of_int dm" 
  using assms
proof (induct xs arbitrary: n d i rule: max_list_rats_with_index.induct)
  case (2 n1 d1 i1 n2 d2 i2 xs n d i)
  let ?r = "rat_of_int" 
  from 2(2) have "d1 > 0" "d2 > 0" by auto
  hence d: "?r d1 > 0" "?r d2 > 0" by auto
  have "(n1 * d2  n2 * d1) = (?r n1 * ?r d2  ?r n2 * ?r d1)" 
    unfolding of_int_mult[symmetric] by presburger
  also have " = (?r n1 / ?r d1  ?r n2 / ?r d2)" using d 
    by (smt divide_strict_right_mono leD le_less_linear mult.commute nonzero_mult_div_cancel_left 
        not_less_iff_gr_or_eq times_divide_eq_right)
  finally have id: "(n1 * d2  n2 * d1) = (?r n1 / ?r d1  ?r n2 / ?r d2)" .
  obtain n' d' i' where new: "(if n1 * d2  n2 * d1 then (n2, d2, i2) else (n1, d1, i1)) = (n',d',i')" 
    by force  
  have nd': "(n',d',i')  {(n1,d1,i1), (n2, d2, i2)}" using new[symmetric] by auto
  from 2(3) have res: "max_list_rats_with_index ((n',d',i') # xs) = (nm, dm, im)" using new by auto
  note 2 = 2[unfolded new]
  show ?case 
  proof (cases "(n,d,i)  set xs")
    case True
    show ?thesis 
      by (rule 2(1)[of n d, OF 2(2) res], insert True nd', force+)
  next
    case False
    with 2(4) have "n = n1  d = d1  n = n2  d = d2" by auto
    hence "?r n / ?r d  ?r n' / ?r d'" using new[unfolded id]
      by (metis linear prod.inject)
    also have "?r n' / ?r d'  ?r nm / ?r dm" 
      by (rule 2(1)[of n' d', OF 2(2) res], insert nd', force+)
    finally show ?thesis .
  qed
qed auto

context LLL
begin

lemma log_base: "log_base  2" unfolding log_base_def by auto

definition LLL_invariant_weak' :: "nat  int vec list  bool" where 
  "LLL_invariant_weak' i fs = ( 
    gs.lin_indpt_list (RAT fs)  
    lattice_of fs = L 
    weakly_reduced fs i 
    i  m  
    length fs = m    
  )" 

lemma LLL_invD_weak: assumes "LLL_invariant_weak' i fs"
  shows 
  "lin_indep fs" 
  "length (RAT fs) = m" 
  "set fs  carrier_vec n"
  " i. i < m  fs ! i  carrier_vec n" 
  " i. i < m  gso fs i  carrier_vec n" 
  "length fs = m"
  "lattice_of fs = L" 
  "weakly_reduced fs i"
  "i  m"
proof (atomize (full), goal_cases)
  case 1
  interpret gs': gram_schmidt_fs_lin_indpt n "RAT fs"
    by (standard) (use assms LLL_invariant_weak'_def gs.lin_indpt_list_def in auto)
  show ?case
    using assms gs'.fs_carrier gs'.f_carrier gs'.gso_carrier
    by (auto simp add: LLL_invariant_weak'_def gram_schmidt_fs.reduced_def)
qed

lemma LLL_invI_weak: assumes  
  "set fs  carrier_vec n"
  "length fs = m"
  "lattice_of fs = L" 
  "i  m"
  "lin_indep fs" 
  "weakly_reduced fs i" 
shows "LLL_invariant_weak' i fs" 
  unfolding LLL_invariant_weak'_def Let_def using assms by auto

lemma LLL_invw'_imp_w: "LLL_invariant_weak' i fs  LLL_invariant_weak fs" 
  unfolding LLL_invariant_weak'_def LLL_invariant_weak_def by auto
  
lemma basis_reduction_add_row_weak: 
  assumes Linvw: "LLL_invariant_weak' i fs"
  and i: "i < m"  and j: "j < i" 
  and fs': "fs' = fs[ i := fs ! i - c v fs ! j]" 
shows "LLL_invariant_weak' i fs'"
  "g_bnd B fs  g_bnd B fs'" 
proof (atomize(full), goal_cases)
  case 1
  note Linv = LLL_invw'_imp_w[OF Linvw]
  note main = basis_reduction_add_row_main[OF Linv i j fs']
  have bnd: "g_bnd B fs  g_bnd B fs'" using main(6) unfolding g_bnd_def by auto
  note new = LLL_inv_wD[OF main(1)]
  note old = LLL_invD_weak[OF Linvw]
  have red: "weakly_reduced fs' i" using ‹weakly_reduced fs i main(6) i < m
    unfolding gram_schmidt_fs.weakly_reduced_def by auto
  have inv: "LLL_invariant_weak' i fs'" using LLL_inv_wD[OF main(1)] i < m
    by (intro LLL_invI_weak, auto intro: red)
  show ?case using inv red main bnd by auto
qed

lemma LLL_inv_weak_m_impl_i:
  assumes inv: "LLL_invariant_weak' m fs"
  and i: "i  m"
shows "LLL_invariant_weak' i fs"
proof -
  have "weakly_reduced fs i" using LLL_invD_weak(8)[OF inv]
    by (meson assms(2) gram_schmidt_fs.weakly_reduced_def le_trans less_imp_le_nat linorder_not_less)
  then show ?thesis
    using LLL_invI_weak[of fs i, OF LLL_invD_weak(3,6,7)[OF inv] _ LLL_invD_weak(1)[OF inv]] 
      LLL_invD_weak(2,4,5,8-)[OF inv] i by simp
qed
 
definition mod_invariant where 
  "mod_invariant b p first = (b  rat_of_int (p - 1)^2 / (rat_of_nat (bound_number first) + 3)
      ( e. p = log_base ^ e))"  

lemma compute_mod_of_max_gso_norm: assumes mn: "mn  0"
  and m: "m = 0  mn = 0" 
  and p: "p = compute_mod_of_max_gso_norm first mn" 
shows  
  "p > 1" 
  "mod_invariant mn p first" 
proof -
  let ?m = "bound_number first" 
  define p' where "p' = root_rat_ceiling 2 (mn * (rat_of_nat ?m + 3)) + 1" 
  define p'' where "p'' = max 2 p'" 
  define q where "q = real_of_rat (mn * (rat_of_nat ?m + 3))" 
  have *: "-1 < (0 :: real)" by simp
  also have "0  root 2 (real_of_rat (mn * (rat_of_nat ?m + 3)))" using mn by auto
  finally have "p'  0 + 1" unfolding p'_def
    by (intro plus_left_mono, simp)
  hence p': "p' > 0" by auto
  have p'': "p'' > 1" unfolding p''_def by auto
  have pp'': "p  p''" unfolding compute_mod_of_max_gso_norm_def p  p'_def[symmetric] p''_def[symmetric]
    using log_base p'' log_ceiling_sound by auto
  hence pp': "p  p'" unfolding p''_def by auto    
  show "p > 1" using pp'' p'' by auto

  have q0: "q  0" unfolding q_def using mn m by auto
  have "(mn  rat_of_int (p' - 1)^2 / (rat_of_nat ?m + 3)) 
    = (real_of_rat mn  real_of_rat (rat_of_int (p' - 1)^2 / (rat_of_nat ?m + 3)))" using of_rat_less_eq by blast
  also have " = (real_of_rat mn  real_of_rat (rat_of_int (p' - 1)^2) / real_of_rat (rat_of_nat ?m + 3))" by (simp add: of_rat_divide)
  also have " = (real_of_rat mn  ((real_of_int (p' - 1))^2) / real_of_rat (rat_of_nat ?m + 3))" 
    by (metis of_rat_of_int_eq of_rat_power)
  also have " = (real_of_rat mn  (real_of_int sqrt q)^2 / real_of_rat (rat_of_nat ?m + 3))" 
    unfolding p'_def sqrt_def q_def by simp
  also have "" 
  proof -
    have "real_of_rat mn  q / real_of_rat (rat_of_nat ?m + 3)" unfolding q_def using m
      by (auto simp: of_rat_mult)
    also have "  (real_of_int sqrt q)^2 / real_of_rat (rat_of_nat ?m + 3)" 
    proof (rule divide_right_mono)
      have "q = (sqrt q)^2" using q0 by simp
      also have "  (real_of_int sqrt q)^2" 
        by (rule power_mono, auto simp: q0)
      finally show "q  (real_of_int sqrt q)^2" .
    qed auto
    finally show ?thesis .
  qed
  finally have "mn  rat_of_int (p' - 1)^2 / (rat_of_nat ?m + 3)" .
  also have "  rat_of_int (p - 1)^2 / (rat_of_nat ?m + 3)"
    unfolding power2_eq_square
    by (intro divide_right_mono mult_mono, insert p' pp', auto) 
  finally have "mn  rat_of_int (p - 1)^2 / (rat_of_nat ?m + 3)" .
  moreover have " e. p = log_base ^ e" unfolding p compute_mod_of_max_gso_norm_def by auto
  ultimately show "mod_invariant mn p first" unfolding mod_invariant_def by auto
qed

lemma g_bnd_mode_cong: assumes " i. i < m  gso fs i = gso fs' i"
  shows "g_bnd_mode first b fs = g_bnd_mode first b fs'"
  using assms unfolding g_bnd_mode_def g_bnd_def by auto

definition LLL_invariant_mod :: "int vec list  int vec list  int mat  int  bool  rat  nat  bool" where 
  "LLL_invariant_mod fs mfs dmu p first b i = ( 
    length fs = m 
    length mfs = m 
    i  m 
    lattice_of fs = L 
    gs.lin_indpt_list (RAT fs) 
    weakly_reduced fs i 
    (map (map_vec (λx. x symmod p)) fs = mfs) 
    (i' < m.  j' < i'. ¦fs i' j'¦ < p * d fs j' * d fs (Suc j')) 
    (i' < m. j' < m.fs i' j' = dmu $$ (i',j')) 
    p > 1 
    g_bnd_mode first b fs 
    mod_invariant b p first
)"

lemma LLL_invD_mod: assumes "LLL_invariant_mod fs mfs dmu p first b i"
shows 
  "length mfs = m"
  "i  m"
  "length fs = m"
  "lattice_of fs = L"
  "gs.lin_indpt_list (RAT fs)"
  "weakly_reduced fs i"
  "(map (map_vec (λx. x symmod p)) fs = mfs)"
  "(i' < m. j' < i'. ¦fs i' j'¦ < p * d fs j' * d fs (Suc j'))"
  "(i' < m. j' < m.fs i' j' = dmu $$ (i',j'))"
  " i. i < m  fs ! i  carrier_vec n" 
  "set fs  carrier_vec n"
  " i. i < m  gso fs i  carrier_vec n" 
  " i. i < m  mfs ! i  carrier_vec n"
  "set mfs  carrier_vec n"
  "p > 1"
  "g_bnd_mode first b fs"
  "mod_invariant b p first"
proof (atomize (full), goal_cases)
  case 1
  interpret gs': gram_schmidt_fs_lin_indpt n "RAT fs"
    using assms LLL_invariant_mod_def gs.lin_indpt_list_def 
    by (meson gram_schmidt_fs_Rn.intro gram_schmidt_fs_lin_indpt.intro gram_schmidt_fs_lin_indpt_axioms.intro)
  have allfs: "i < m. fs ! i  carrier_vec n" using assms gs'.f_carrier 
    by (simp add: LLL.LLL_invariant_mod_def)
  then have setfs: "set fs  carrier_vec n" by (metis LLL_invariant_mod_def assms in_set_conv_nth subsetI)
  have allgso: "(i < m. gso fs i  carrier_vec n)" using assms gs'.gso_carrier
    by (simp add: LLL.LLL_invariant_mod_def)
  show ?case
    using assms gs'.fs_carrier gs'.f_carrier gs'.gso_carrier allfs allgso 
      LLL_invariant_mod_def gram_schmidt_fs.reduced_def in_set_conv_nth setfs by fastforce
qed

lemma LLL_invI_mod: assumes 
  "length mfs = m"
  "i  m"
  "length fs = m"
  "lattice_of fs = L"
  "gs.lin_indpt_list (RAT fs)"
  "weakly_reduced fs i"
  "map (map_vec (λx. x symmod p)) fs = mfs"
  "(i' < m. j' < i'. ¦fs i' j'¦ < p * d fs j' * d fs (Suc j'))"
  "(i' < m. j' < m.fs i' j' = dmu $$ (i',j'))"
  "p > 1"
  "g_bnd_mode first b fs"
  "mod_invariant b p first"
shows "LLL_invariant_mod fs mfs dmu p first b i" 
  unfolding LLL_invariant_mod_def using assms by blast

definition LLL_invariant_mod_weak :: "int vec list  int vec list  int mat  int  bool  rat  bool" where 
  "LLL_invariant_mod_weak fs mfs dmu p first b = ( 
    length fs = m 
    length mfs = m 
    lattice_of fs = L 
    gs.lin_indpt_list (RAT fs) 
    (map (map_vec (λx. x symmod p)) fs = mfs) 
    (i' < m.  j' < i'. ¦fs i' j'¦ < p * d fs j' * d fs (Suc j')) 
    (i' < m. j' < m.fs i' j' = dmu $$ (i',j')) 
    p > 1 
    g_bnd_mode first b fs 
    mod_invariant b p first
)"

lemma LLL_invD_modw: assumes "LLL_invariant_mod_weak fs mfs dmu p first b"
shows 
  "length mfs = m"
  "length fs = m"
  "lattice_of fs = L"
  "gs.lin_indpt_list (RAT fs)"
  "(map (map_vec (λx. x symmod p)) fs = mfs)"
  "(i' < m. j' < i'. ¦fs i' j'¦ < p * d fs j' * d fs (Suc j'))"
  "(i' < m. j' < m.fs i' j' = dmu $$ (i',j'))"
  " i. i < m  fs ! i  carrier_vec n" 
  "set fs  carrier_vec n"
  " i. i < m  gso fs i  carrier_vec n" 
  " i. i < m  mfs ! i  carrier_vec n"
  "set mfs  carrier_vec n"
  "p > 1"
  "g_bnd_mode first b fs"
  "mod_invariant b p first"
proof (atomize (full), goal_cases)
  case 1
  interpret gs': gram_schmidt_fs_lin_indpt n "RAT fs"
    using assms LLL_invariant_mod_weak_def gs.lin_indpt_list_def 
    by (meson gram_schmidt_fs_Rn.intro gram_schmidt_fs_lin_indpt.intro gram_schmidt_fs_lin_indpt_axioms.intro)
  have allfs: "i < m. fs ! i  carrier_vec n" using assms gs'.f_carrier 
    by (simp add: LLL.LLL_invariant_mod_weak_def)
  then have setfs: "set fs  carrier_vec n" by (metis LLL_invariant_mod_weak_def assms in_set_conv_nth subsetI)
  have allgso: "(i < m. gso fs i  carrier_vec n)" using assms gs'.gso_carrier
    by (simp add: LLL.LLL_invariant_mod_weak_def)
  show ?case
    using assms gs'.fs_carrier gs'.f_carrier gs'.gso_carrier allfs allgso 
      LLL_invariant_mod_weak_def gram_schmidt_fs.reduced_def in_set_conv_nth setfs by fastforce
qed

lemma LLL_invI_modw: assumes 
  "length mfs = m"
  "length fs = m"
  "lattice_of fs = L"
  "gs.lin_indpt_list (RAT fs)"
  "map (map_vec (λx. x symmod p)) fs = mfs"
  "(i' < m. j' < i'. ¦fs i' j'¦ < p * d fs j' * d fs (Suc j'))"
  "(i' < m. j' < m.fs i' j' = dmu $$ (i',j'))"
  "p > 1"
  "g_bnd_mode first b fs"
  "mod_invariant b p first"
shows "LLL_invariant_mod_weak fs mfs dmu p first b" 
  unfolding LLL_invariant_mod_weak_def using assms by blast

lemma ddμ:
  assumes i: "i < m"
  shows "d fs (Suc i) =fs i i"
proof-
  have fs i i = 1" using i by (simp add: gram_schmidt_fs.μ.simps)
  then show ?thesis using dμ_def by simp
qed

lemma d_of_main: assumes "(i' < m.fs i' i' = dmu $$ (i',i'))"
  and "i  m"
shows "d_of dmu i = d fs i" 
proof (cases "i = 0")
  case False
  with assms have "i - 1 < m" by auto
  from assms(1)[rule_format, OF this] ddμ[OF this, of fs] False
  show ?thesis by (simp add: d_of_def)
next
  case True
  thus ?thesis unfolding d_of_def True d_def by simp
qed

lemma d_of: assumes inv: "LLL_invariant_mod fs mfs dmu p b first j"
  and "i  m" 
shows "d_of dmu i = d fs i" 
  by (rule d_of_main[OF _ assms(2)], insert LLL_invD_mod(9)[OF inv], auto)

lemma d_of_weak: assumes inv: "LLL_invariant_mod_weak fs mfs dmu p first b"
  and "i  m" 
shows "d_of dmu i = d fs i" 
  by (rule d_of_main[OF _ assms(2)], insert LLL_invD_modw(7)[OF inv], auto)

lemma compute_max_gso_norm: assumes dmu: "(i' < m.fs i' i' = dmu $$ (i',i'))" 
  and Linv: "LLL_invariant_weak fs" 
shows "g_bnd_mode first (fst (compute_max_gso_norm first dmu)) fs" 
  "fst (compute_max_gso_norm first dmu)  0" 
  "m = 0  fst (compute_max_gso_norm first dmu) = 0" 
proof -
  show gbnd: "g_bnd_mode first (fst (compute_max_gso_norm first dmu)) fs" 
  proof (cases "first  m  0")
    case False
    have "?thesis = (g_bnd (fst (compute_max_gso_norm first dmu)) fs)" unfolding g_bnd_mode_def using False by auto
    also have  unfolding g_bnd_def
    proof (intro allI impI)
      fix i
      assume i: "i < m" 
      have id: "(if first then 1 else m) = m" using False i by auto
      define list where "list = map (λ i. (d_of dmu (Suc i), d_of dmu i, i)) [0 ..< m ]" 
      obtain num denom j where ml: "max_list_rats_with_index list = (num, denom, j)" 
        by (metis prod_cases3)
      have dpos: "d fs i > 0" using LLL_d_pos[OF Linv, of i]  i by auto
      have pos: "(n, d, i)  set list  0 < d" for n d i 
        using LLL_d_pos[OF Linv] unfolding list_def using d_of_main[OF dmu] by auto
      from i have "list ! i  set list" using i unfolding list_def by auto
      also have "list ! i = (d_of dmu (Suc i), d_of dmu i, i)" unfolding list_def using i by auto
      also have " = (d fs (Suc i), d fs i, i)" using d_of_main[OF dmu] i by auto
      finally have "(d fs (Suc i), d fs i, i)  set list" . 
      from max_list_rats_with_index[OF pos ml this] 
      have "of_int (d fs (Suc i)) / of_int (d fs i)  fst (compute_max_gso_norm first dmu)" 
        unfolding compute_max_gso_norm_def list_def[symmetric] ml id split using i by auto
      also have "of_int (d fs (Suc i)) / of_int (d fs i) = sq_norm (gso fs i)" 
        using LLL_d_Suc[OF Linv i] dpos by auto
      finally show "sq_norm (gso fs i)  fst (compute_max_gso_norm first dmu)" .
    qed
    finally show ?thesis .
  next
    case True
    thus ?thesis unfolding g_bnd_mode_def compute_max_gso_norm_def using d_of_main[OF dmu] 
      LLL_d_Suc[OF Linv, of 0] LLL_d_pos[OF Linv, of 0] LLL_d_pos[OF Linv, of 1] by auto
  qed
  show "fst (compute_max_gso_norm first dmu)  0" 
  proof (cases "m = 0")
    case True
    thus ?thesis unfolding compute_max_gso_norm_def by simp
  next
    case False
    hence 0: "0 < m" by simp
    have "0  sq_norm (gso fs 0)" by blast
    also have "  fst (compute_max_gso_norm first dmu)" 
      using gbnd[unfolded g_bnd_mode_def g_bnd_def] using 0 by metis
    finally show ?thesis .
  qed
qed (auto simp: LLL.compute_max_gso_norm_def)


lemma increase_i_mod:
  assumes Linv: "LLL_invariant_mod fs mfs dmu p first b i"
  and i: "i < m" 
  and red_i: "i  0  sq_norm (gso fs (i - 1))  α * sq_norm (gso fs i)"
shows "LLL_invariant_mod fs mfs dmu p first b (Suc i)" "LLL_measure i fs > LLL_measure (Suc i) fs" 
proof -
  note inv = LLL_invD_mod[OF Linv]
  from inv have red: "weakly_reduced fs i"  by (auto)
  from red red_i i have red: "weakly_reduced fs (Suc i)" 
    unfolding gram_schmidt_fs.weakly_reduced_def
    by (intro allI impI, rename_tac ii, case_tac "Suc ii = i", auto)
  show "LLL_invariant_mod fs mfs dmu p first b (Suc i)"
    by (intro LLL_invI_mod, insert inv red i, auto)
  show "LLL_measure i fs > LLL_measure (Suc i) fs" unfolding LLL_measure_def using i by auto
qed

lemma basis_reduction_mod_add_row_main:
  assumes Linvmw: "LLL_invariant_mod_weak fs mfs dmu p first b"
  and i: "i < m"  and j: "j < i" 
  and c: "c = round (μ fs i j)"
  and mfs': "mfs' = mfs[ i := (map_vec (λ x. x symmod p)) (mfs ! i - c v mfs ! j)]"
  and dmu': "dmu' = mat m m (λ(i',j'). (if (i' = i  j'  j) 
        then (if j'=j then (dmu $$ (i,j') - c * dmu $$ (j,j')) 
              else (dmu $$ (i,j') - c * dmu $$ (j,j')) 
                    symmod (p * (d_of dmu j') * (d_of dmu (Suc j'))))
        else (dmu $$ (i',j'))))"
shows "(fs'. LLL_invariant_mod_weak fs' mfs' dmu' p first b 
        LLL_measure i fs' = LLL_measure i fs
         (μ_small_row i fs (Suc j)  μ_small_row i fs' j) 
         (k < m. gso fs' k = gso fs k)
         (ii  m. d fs' ii = d fs ii)
         ¦μ fs' i j¦  1 / 2
         (i' j'. i' < i  j'  i'  μ fs' i' j' = μ fs i' j')
         (LLL_invariant_mod fs mfs dmu p first b i  LLL_invariant_mod fs' mfs' dmu' p first b i))"
proof -
  define fs' where "fs' = fs[ i := fs ! i - c v fs ! j]"
  from LLL_invD_modw[OF Linvmw] have gbnd: "g_bnd_mode first b fs" and p1: "p > 1" and pgtz: "p > 0" by auto
  have Linvww: "LLL_invariant_weak fs" using LLL_invD_modw[OF Linvmw] LLL_invariant_weak_def by simp
  have 
    Linvw': "LLL_invariant_weak fs'" and
    01: "c = round (μ fs i j)  μ_small_row i fs (Suc j)  μ_small_row i fs' j" and
    02: "LLL_measure i fs' = LLL_measure i fs" and
    03: " i. i < m  gso fs' i = gso fs i" and
    04: " i' j'. i' < m  j' < m  
      μ fs' i' j' = (if i' = i  j'  j then μ fs i j' - of_int c * μ fs j j' else μ fs i' j')" and
    05: " ii. ii  m  d fs' ii = d fs ii" and 
    06: "¦μ fs' i j¦  1 / 2" and
    061: "(i' j'. i' < i  j'  i'  μ fs i' j' = μ fs' i' j')"
    using basis_reduction_add_row_main[OF Linvww i j fs'_def] c i by auto
  have 07: "lin_indep fs'" and 
    08: "length fs' = m" and 
    09: "lattice_of fs' = L" using LLL_inv_wD Linvw' by auto
  have 091: "fs_int_indpt n fs'" using 07 using Gram_Schmidt_2.fs_int_indpt.intro by simp
  define I where "I = {(i',j'). i' = i  j' < j}"
  have 10: "I  {(i',j'). i' < m  j' < i'}" "(i,j) I" "j'  j. (i,j')  I" using I_def i j by auto
  obtain fs'' where 
    11: "lattice_of fs'' = L" and
    12: "map (map_vec (λ x. x symmod p)) fs'' = map (map_vec (λ x. x symmod p)) fs'" and
    13: "lin_indep fs''" and
    14: "length fs'' = m" and
    15: "( k < m. gso fs'' k = gso fs' k)" and
    16: "( k  m. d fs'' k = d fs' k)" and
    17: "( i' < m.  j' < m.fs'' i' j' = 
      (if (i',j')  I thenfs' i' j' symmod (p * d fs' j' * d fs' (Suc j')) elsefs' i' j'))"
    using mod_finite_set[OF 07 08 10(1) 09 pgtz] by blast
  have 171: "(i' j'. i' < i  j'  i'  μ fs'' i' j' = μ fs' i' j')"
  proof -
    {
      fix i' j'
      assume i'j': "i' < i" "j'  i'"
      have "rat_of_int (fs'' i' j') = rat_of_int (fs' i' j')" using "17" I_def i i'j' by auto
      then have "rat_of_int (int_of_rat (rat_of_int (d fs'' (Suc j')) * μ fs'' i' j')) = 
        rat_of_int (int_of_rat (rat_of_int (d fs' (Suc j')) * μ fs' i' j'))"
        using dμ_def i'j' j by auto
      then have "rat_of_int (d fs'' (Suc j')) * μ fs'' i' j' = 
        rat_of_int (d fs' (Suc j')) * μ fs' i' j'" 
        by (smt "08" "091" "13" "14" d_def dual_order.strict_trans fs_int.d_def 
            fs_int_indpt.fs_int_mu_d_Z fs_int_indpt.intro i i'j'(1) i'j'(2) int_of_rat(2))
      then have fs'' i' j' = μ fs' i' j'" by (smt "16" 
            LLL_d_pos[OF Linvw'] Suc_leI int_of_rat(1)
            dual_order.strict_trans fs'_def i i'j' j 
            le_neq_implies_less nonzero_mult_div_cancel_left of_int_hom.hom_zero)
    }
    then show ?thesis by simp
  qed
  then have 172: "(i' j'. i' < i  j'  i'  μ fs'' i' j' = μ fs i' j')" using 061 by simp (* goal *)
  have 18: "LLL_measure i fs'' = LLL_measure i fs'" using 16 LLL_measure_def logD_def D_def by simp
  have 19: "(k < m. gso fs'' k = gso fs k)" using 03 15 by simp
  have "j'  {j..(m-1)}. j' < m" using j i by auto
  then have 20: "j'  {j..(m-1)}.fs'' i j' =fs' i j'" 
    using 10(3) 17 Suc_lessD less_trans_Suc by (meson atLeastAtMost_iff i)
  have 21: "j'  {j..(m-1)}. μ fs'' i j' = μ fs' i j'" 
  proof -
    {
      fix j'
      assume j': "j'  {j..(m-1)}"
      define μ'' :: rat where "μ'' = μ fs'' i j'"
      define μ' :: rat where "μ' = μ fs' i j'"
      have "rat_of_int (fs'' i j') = rat_of_int (fs' i j')" using 20 j' by simp
      moreover have "j' < length fs'" using i j' 08 by auto
      ultimately have "rat_of_int (d fs' (Suc j')) * gram_schmidt_fs.μ n (map of_int_hom.vec_hom fs') i j'
        = rat_of_int (d fs'' (Suc j')) * gram_schmidt_fs.μ n (map of_int_hom.vec_hom fs'') i j'"
        using 20 08 091 13 14 fs_int_indpt.dμ_def fs_int.d_def fs_int_indpt.dμ dμ_def d_def i fs_int_indpt.intro j'
        by metis
      then have "rat_of_int (d fs' (Suc j')) * μ'' = rat_of_int (d fs' (Suc j')) * μ'" 
        using 16 i j' μ'_def μ''_def unfolding dμ_def by auto
      moreover have "0 < d fs' (Suc j')" using LLL_d_pos[OF Linvw', of "Suc j'"] i j' by auto
      ultimately have fs'' i j' = μ fs' i j'" using μ'_def μ''_def by simp
    }
    then show ?thesis by simp
  qed
  then have 22: fs'' i j = μ fs' i j" using i j by simp
  then have 23: "¦μ fs'' i j¦  1 / 2" using 06 by simp (* goal *)
  have 24: "LLL_measure i fs'' = LLL_measure i fs" using 02 18 by simp (* goal *)
  have 25: "( k  m. d fs'' k = d fs k)" using 16 05 by simp (* goal *)
  have 26: "( k < m. gso fs'' k = gso fs k)" using 15 03 by simp (* goal *)
  have 27: "μ_small_row i fs (Suc j)  μ_small_row i fs'' j"
    using 21 01 μ_small_row_def i j c by auto (* goal *)
  have 28: "length fs = m" "length mfs = m" using LLL_invD_modw[OF Linvmw] by auto
  have 29: "map (map_vec (λx. x symmod p)) fs = mfs" using assms LLL_invD_modw by simp
  have 30: " i. i < m  fs ! i  carrier_vec n" " i. i < m  mfs ! i  carrier_vec n"
    using LLL_invD_modw[OF Linvmw] by auto
  have 31: " i. i < m  fs' ! i  carrier_vec n" using fs'_def 30(1) 
    using "08" "091" fs_int_indpt.f_carrier by blast
  have 32: " i. i < m  mfs' ! i  carrier_vec n" unfolding mfs' using 30(2) 28(2) 
    by (metis (no_types, lifting) Suc_lessD j less_trans_Suc map_carrier_vec minus_carrier_vec 
        nth_list_update_eq nth_list_update_neq smult_closed)
  have 33: "length mfs' = m" using 28(2) mfs' by simp (* invariant goal *)
  then have 34: "map (map_vec (λx. x symmod p)) fs' = mfs'"
  proof -
    {
      fix i' j'
      have j2: "j < m" using j i by auto
      assume i': "i' < m"
      assume j': "j' < n"
      then have fsij: "(fs ! i' $ j') symmod p = mfs ! i' $ j'" using 30 i' j' 28 29 by fastforce
      have "mfs' ! i $ j' = (mfs ! i $ j'- (c v mfs ! j) $ j') symmod p"
        unfolding mfs' using 30(2) j' 28 j2 
        by (metis (no_types, lifting) carrier_vecD i index_map_vec(1) index_minus_vec(1) 
            index_minus_vec(2) index_smult_vec(2) nth_list_update_eq)
      then have mfs'ij: "mfs' ! i $ j' = (mfs ! i $ j'- c * mfs ! j $ j') symmod p" 
        unfolding mfs' using 30(2) i' j' 28 j2 by fastforce
      have "(fs' ! i' $ j') symmod p = mfs' ! i' $ j'"
      proof(cases "i' = i")
        case True
        show ?thesis using fs'_def mfs' True 28 fsij 
        proof -
          have "fs' ! i' $ j' = (fs ! i' - c v fs ! j) $ j'" using fs'_def True i' j' 28(1) by simp
          also have " = fs ! i' $ j' - (c v fs ! j) $ j'" using i' j' 30(1)
            by (metis Suc_lessD carrier_vecD i index_minus_vec(1) index_smult_vec(2) j less_trans_Suc)
          finally have "fs' ! i' $ j' = fs ! i' $ j' - (c v fs ! j) $ j'" by auto
          then have "(fs' ! i' $ j') symmod p = (fs ! i' $ j' - (c v fs ! j) $ j') symmod p" by auto
          also have " = ((fs ! i' $ j') symmod p - ((c v fs ! j) $ j') symmod p) symmod p"
            by (simp add: sym_mod_diff_eq)
          also have "(c v fs ! j) $ j' = c * (fs ! j $ j')" 
            using i' j' True 28 30(1) j
            by (metis Suc_lessD carrier_vecD index_smult_vec(1) less_trans_Suc)
          also have "((fs ! i' $ j') symmod p - (c * (fs ! j $ j')) symmod p) symmod p = 
            ((fs ! i' $ j') symmod p - c * ((fs ! j $ j') symmod p)) symmod p" 
            using i' j' True 28 30(1) j by (metis sym_mod_diff_right_eq sym_mod_mult_right_eq)
          also have "((fs ! j $ j') symmod p) = mfs ! j $ j'" using 30 i' j' 28 29 j2 by fastforce
          also have "((fs ! i' $ j') symmod p - c * mfs ! j $ j') symmod p = 
            (mfs ! i' $ j' - c * mfs ! j $ j') symmod p" using fsij by simp
          finally show ?thesis using mfs'ij by (simp add: True)
        qed
      next
        case False
        show ?thesis using fs'_def mfs' False 28 fsij by simp
      qed
    }
    then have "i' < m. (map_vec (λx. x symmod p)) (fs' ! i') = mfs' ! i'"
      using 31 32 33 08 by fastforce
    then show ?thesis using 31 32 33 08 by (simp add: map_nth_eq_conv)
  qed
  then have 35: "map (map_vec (λx. x symmod p)) fs'' = mfs'" using 12 by simp (* invariant req. *)
  have 36: "lin_indep fs''"  using 13 by simp (* invariant req. *)
  have Linvw'': "LLL_invariant_weak fs''" using LLL_invariant_weak_def 11 13 14 by simp
  have 39: "(i' < m. j' < i'. ¦fs'' i' j'¦ < p * d fs'' j' * d fs'' (Suc j'))" (* invariant req. *)
  proof -
    {
      fix i' j'
      assume i': "i' < m"
      assume j': "j' < i'"
      define pdd where "pdd = (p * d fs'' j' * d fs'' (Suc j'))"
      then have pddgtz: "pdd > 0" 
        using pgtz j' LLL_d_pos[OF Linvw', of "Suc j'"] LLL_d_pos[OF Linvw', of j'] j' i' 16 by simp
      have "¦fs'' i' j'¦ < p * d fs'' j' * d fs'' (Suc j')"
      proof(cases "i' = i")
        case i'i: True
        then show ?thesis
        proof (cases "j' < j")
          case True
          then have eq'': "dμ fs'' i' j' =fs' i' j' symmod (p * d fs'' j' * d fs'' (Suc j'))"
            using 16 17 10 I_def True i' j' i'i by simp
          have "0 < pdd" using pddgtz by simp
          then show ?thesis unfolding eq'' unfolding pdd_def[symmetric] using sym_mod_abs by blast
        next
          case fls: False
          then have "(i',j')  I" using I_def i'i by simp
          then have dmufs''fs': "dμ fs'' i' j' =fs' i' j'" using 17 i' j' by simp
          show ?thesis
          proof (cases "j' = j")
            case True
            define μ'' where "μ'' = μ fs'' i' j'" 
            define d'' where "d'' = d fs'' (Suc j')"
            have pge1: "p  1" using pgtz by simp
            have lh: "¦μ''¦  1 / 2" using 23 True i'i μ''_def by simp
            moreover have eq: "dμ fs'' i' j' = μ'' * d''" using dμ_def i' j' μ''_def d''_def 
              by (smt "14" "36" LLL.d_def Suc_lessD fs_int.d_def fs_int_indpt.dμ fs_int_indpt.intro 
                  int_of_rat(1) less_trans_Suc mult_of_int_commute of_rat_mult of_rat_of_int_eq)
            moreover have Sj': "Suc j'  m" "j'  m" using True j' i i' by auto
            moreover then have gtz: "0 < d''" using LLL_d_pos[OF Linvw''] d''_def by simp
            moreover have "rat_of_int ¦fs'' i' j'¦ = ¦μ'' * (rat_of_int d'')¦" 
              using eq by (metis of_int_abs of_rat_hom.injectivity of_rat_mult of_rat_of_int_eq)
            moreover then have "¦μ'' * rat_of_int d'' ¦ =  ¦μ''¦ * rat_of_int ¦d''¦"
              by (metis (mono_tags, hide_lams) abs_mult of_int_abs)
            moreover have " = ¦μ''¦ * rat_of_int d'' " using gtz by simp
            moreover have " < rat_of_int d''" using lh gtz by simp
            ultimately have "rat_of_int ¦fs'' i' j'¦ < rat_of_int d''" by simp
            then have "¦fs'' i' j'¦ <  d fs'' (Suc j')" using d''_def by simp
            then have "¦fs'' i' j'¦ < p * d fs'' (Suc j')" using pge1
              by (smt mult_less_cancel_right2)
            then show ?thesis using pge1 LLL_d_pos[OF Linvw'' Sj'(2)] gtz unfolding d''_def
              by (smt mult_less_cancel_left2 mult_right_less_imp_less)
          next
            case False
            have "j' < m" using i' j' by simp
            moreover have "j' > j" using False fls by simp
            ultimately have fs' i' j' = μ fs i' j'" using i' 04 i by simp
            then have "dμ fs' i' j' =fs i' j'" using dμ_def i' j' 05 by simp
            then have "dμ fs'' i' j' =fs i' j'" using dmufs''fs' by simp
            then show ?thesis using LLL_invD_modw[OF Linvmw] i' j' 25 by simp
          qed
        qed
      next
        case False
        then have "(i',j')  I" using I_def by simp
        then have dmufs''fs': "dμ fs'' i' j' =fs' i' j'" using 17 i' j' by simp
        have fs' i' j' = μ fs i' j'" using i' 04 j' False by simp
        then have "dμ fs' i' j' =fs i' j'" using dμ_def i' j' 05 by simp
        moreover then have "dμ fs'' i' j' =fs i' j'" using dmufs''fs' by simp
        then show ?thesis using LLL_invD_modw[OF Linvmw] i' j' 25 by simp
      qed
    }
    then show ?thesis by simp
  qed
  have 40: "(i' < m. j' < m. i'  i  j' > j fs' i' j' = dmu $$ (i',j'))"
  proof -
    {
      fix i' j'
      assume i': "i' < m" and j': "j' < m"
      assume assm: "i'  i  j' > j"
      have "dμ fs' i' j' = dmu $$ (i',j')"
      proof (cases "i'  i")
        case True
        then show ?thesis using fs'_def LLL_invD_modw[OF Linvmw] dμ_def i i' j j'
          04 28(1) LLL_invI_weak basis_reduction_add_row_main(8)[OF Linvww] by auto
      next
        case False
        then show ?thesis 
          using 05 LLL_invD_modw[OF Linvmw] dμ_def i j j' 04 assm by simp
      qed
    }
    then show ?thesis by simp
  qed
  have 41: "j'  j.fs' i j' = dmu $$ (i,j') - c * dmu $$ (j,j')"
  proof -
    {
      let ?oi = "of_int :: _  rat" 
      fix j'
      assume j': "j'  j"
      define dj' μi μj where "dj' = d fs (Suc j')" and "μi = μ fs i j'" and "μj = μ fs j j'"
      have "?oi (fs' i j') = ?oi (d fs (Suc j')) * (μ fs i j' - ?oi c * μ fs j j')"
        using j' 04 dμ_def 
        by (smt "05" "08" "091" Suc_leI d_def diff_diff_cancel fs_int.d_def 
            fs_int_indpt.fs_int_mu_d_Z i int_of_rat(2) j less_imp_diff_less less_imp_le_nat)
      also have " = (?oi dj') * (μi - of_int c * μj)" 
        using dj'_def μi_def μj_def by (simp add: of_rat_mult)
      also have " = (rat_of_int dj') * μi - of_int c * (rat_of_int dj') * μj" by algebra
      also have " = rat_of_int (fs i j') - ?oi c * rat_of_int (fs j j')" unfolding dj'_def μi_def μj_def
        using i j j' dμ_def
        using "28"(1) LLL.LLL_invD_modw(4) Linvmw d_def fs_int.d_def fs_int_indpt.fs_int_mu_d_Z fs_int_indpt.intro by auto
      also have " = rat_of_int (dmu $$ (i,j')) - ?oi c * rat_of_int (dmu $$ (j,j'))" 
        using LLL_invD_modw(7)[OF Linvmw] dμ_def j' i j by auto
      finally have "?oi (fs' i j') = rat_of_int (dmu $$ (i,j')) - ?oi c * rat_of_int (dmu $$ (j,j'))" by simp
      then have "dμ fs' i j' = dmu $$ (i,j') - c * dmu $$ (j,j')"
        using of_int_eq_iff by fastforce
    }
    then show ?thesis by simp
  qed
  have 42: "(i' < m. j' < m.fs'' i' j' = dmu' $$ (i',j'))"
  proof -
    {
      fix i' j'
      assume i': "i' < m" and j': "j' < m"
      have "dμ fs'' i' j' = dmu' $$ (i',j')" 
      proof (cases "i' = i")
        case i'i: True
        then show ?thesis
        proof (cases "j' > j")
          case True
          then have "(i',j')I" using I_def by simp
          moreover then have "dμ fs' i' j' =fs i' j'" using "04" "05" True Suc_leI dμ_def i' j' by simp
          moreover have "dmu' $$ (i',j') = dmu $$ (i',j')" using dmu' True i' j' by simp
          ultimately show ?thesis using "17" "40" True i' j' by auto
        next
          case False
          then have j'lej: "j'  j" by simp
          then have eq': "dμ fs' i j' = dmu $$ (i,j') - c * dmu $$ (j,j')" using 41 by simp
          have id: "d_of dmu j' = d fs j'" "d_of dmu (Suc j') = d fs (Suc j')" 
            using d_of_weak[OF Linvmw] j' < m by auto
          show ?thesis
          proof (cases "j'  j")
            case True
            then have j'ltj: "j' < j" using True False by simp
            then have "(i',j')  I" using I_def True i'i by simp
            then have "dμ fs'' i' j' = 
              (dmu $$ (i,j') - c * dmu $$ (j,j')) symmod (p * d fs' j' * d fs' (Suc j'))"
              using 17 i' 41 j'lej by (simp add: j' i'i)
            also have " = (dmu $$ (i,j') - c * dmu $$ (j,j')) symmod (p * d fs j' * d fs (Suc j'))"
              using 05 i j'ltj j by simp
            also have " = dmu' $$ (i,j')" 
              unfolding dmu' index_mat(1)[OF i < m j' < m] split id using j'lej True by auto
            finally show ?thesis using i'i by simp
          next
            case False
            then have j'j: "j' = j" by simp
            then have "dμ fs'' i j' =fs' i j'" using 20 j' by simp
            also have " = dmu $$ (i,j') - c * dmu $$ (j,j')" using eq' by simp
            also have " = dmu' $$ (i,j')" using dmu' j'j i j' by simp
            finally show ?thesis using i'i by simp
          qed
        qed
      next
        case False
        then have "(i',j')I" using I_def by simp
        moreover then have "dμ fs' i' j' =fs i' j'" by (simp add: "04" "05" False Suc_leI dμ_def i' j')
        moreover then have "dmu' $$ (i',j') = dmu $$ (i',j')" using dmu' False i' j' by simp
        ultimately show ?thesis using "17" "40" False i' j' by auto
      qed
    }
    then show ?thesis by simp
  qed
  from gbnd 26 have gbnd: "g_bnd_mode first b fs''" using g_bnd_mode_cong[of fs'' fs] by simp
  {
    assume Linv: "LLL_invariant_mod fs mfs dmu p first b i"
    have Linvw: "LLL_invariant_weak' i fs" using Linv LLL_invD_mod LLL_invI_weak by simp
    note Linvww = LLL_invw'_imp_w[OF Linvw]
    have 00: "LLL_invariant_weak' i fs'" using Linvw basis_reduction_add_row_weak[OF Linvw i j fs'_def] by auto
    have 37: "weakly_reduced fs'' i" using 15 LLL_invD_weak(8)[OF 00] gram_schmidt_fs.weakly_reduced_def 
      by (smt Suc_lessD i less_trans_Suc) (* invariant req. *)
    have 38: "LLL_invariant_weak' i fs''"
      using 00 11 14 36 37 i 31 12  LLL_invariant_weak'_def by blast
    have "LLL_invariant_mod fs'' mfs' dmu' p first b i"
      using LLL_invI_mod[OF 33 _ 14 11 13 37 35 39 42 p1 gbnd LLL_invD_mod(17)[OF Linv]] i by simp
  }
  moreover have "LLL_invariant_mod_weak fs'' mfs' dmu' p first b"
    using LLL_invI_modw[OF 33 14 11 13 35 39 42 p1 gbnd LLL_invD_modw(15)[OF Linvmw]] by simp
  ultimately show ?thesis using 27 23 24 25 26 172 by auto
qed

definition D_mod :: "int mat  nat" where "D_mod dmu = nat ( i < m. d_of dmu i)"

definition logD_mod :: "int mat  nat"
  where "logD_mod dmu = (if α = 4/3 then (D_mod dmu) else nat (floor (log (1 / of_rat reduction) (D_mod dmu))))" 
end

locale fs_int'_mod = 
  fixes n m fs_init α i fs mfs dmu p first b 
  assumes LLL_inv_mod: "LLL.LLL_invariant_mod n m fs_init α fs mfs dmu p first b i"

context LLL_with_assms
begin

lemma basis_reduction_swap_weak': assumes Linvw: "LLL_invariant_weak' i fs"
  and i: "i < m"
  and i0: "i  0"
  and mu_F1_i: "¦μ fs i (i-1)¦  1 / 2"
  and norm_ineq: "sq_norm (gso fs (i - 1)) > α * sq_norm (gso fs i)" 
  and fs'_def: "fs' = fs[i := fs ! (i - 1), i - 1 := fs ! i]" 
shows "LLL_invariant_weak' (i - 1) fs'" 
proof -
  note inv = LLL_invD_weak[OF Linvw]
  note invw = LLL_invw'_imp_w[OF Linvw]
  note main = basis_reduction_swap_main[OF invw disjI2[OF mu_F1_i] i i0 norm_ineq fs'_def]
  note inv' = LLL_inv_wD[OF main(1)]
  from ‹weakly_reduced fs i have "weakly_reduced fs (i - 1)" 
    unfolding gram_schmidt_fs.weakly_reduced_def by auto
  also have "weakly_reduced fs (i - 1) = weakly_reduced fs' (i - 1)" 
    unfolding gram_schmidt_fs.weakly_reduced_def 
    by (intro all_cong, insert i0 i main(5), auto)
  finally have red: "weakly_reduced fs' (i - 1)" .
  show "LLL_invariant_weak' (i - 1) fs'" using i
    by (intro LLL_invI_weak red inv', auto)
qed

lemma basis_reduction_add_row_done_weak: 
  assumes Linv: "LLL_invariant_weak' i fs"
  and i: "i < m" 
  and mu_small: "μ_small_row i fs 0" 
shows "μ_small fs i"
proof -
  note inv = LLL_invD_weak[OF Linv]
  from mu_small 
  have mu_small: "μ_small fs i" unfolding μ_small_row_def μ_small_def by auto
  show ?thesis
    using i mu_small LLL_invI_weak[OF inv(3,6,7,9,1)] by auto
qed     

lemma LLL_invariant_mod_to_weak_m_to_i: assumes
  inv: "LLL_invariant_mod fs mfs dmu p first b m"
  and i: "i  m"
shows "LLL_invariant_mod fs mfs dmu p first b i"
  "LLL_invariant_weak' m fs"
  "LLL_invariant_weak' i fs"
proof -
  show "LLL_invariant_mod fs mfs dmu p first b i" 
  proof -
    have "LLL_invariant_weak' m fs" using LLL_invD_mod[OF inv] LLL_invI_weak by simp
    then have "LLL_invariant_weak' i fs" using LLL_inv_weak_m_impl_i i by simp
    then have "weakly_reduced fs i" using i LLL_invD_weak(8) by simp
    then show ?thesis using LLL_invD_mod[OF inv] LLL_invI_mod i by simp
  qed
  then show fsinvwi: "LLL_invariant_weak' i fs" using LLL_invD_mod LLL_invI_weak by simp
  show "LLL_invariant_weak' m fs" using LLL_invD_mod[OF inv] LLL_invI_weak by simp
qed

lemma basis_reduction_mod_swap_main: 
  assumes Linvmw: "LLL_invariant_mod_weak fs mfs dmu p first b"
  and k: "k < m"
  and k0: "k  0"
  and mu_F1_i: "¦μ fs k (k-1)¦  1 / 2"
  and norm_ineq: "sq_norm (gso fs (k - 1)) > α * sq_norm (gso fs k)" 
  and mfs'_def: "mfs' = mfs[k := mfs ! (k - 1), k - 1 := mfs ! k]"
  and dmu'_def: "dmu' = (mat m m (λ(i,j). (
      if j < i then
        if i = k - 1 then 
           dmu $$ (k, j)
        else if i = k  j  k - 1 then 
             dmu $$ (k - 1, j)
        else if i > k  j = k then
           ((d_of dmu (Suc k)) * dmu $$ (i, k - 1) - dmu $$ (k, k - 1) * dmu $$ (i, j)) 
              div (d_of dmu k)
        else if i > k  j = k - 1 then
           (dmu $$ (k, k - 1) * dmu $$ (i, j) + dmu $$ (i, k) * (d_of dmu (k-1)))
              div (d_of dmu k)
        else dmu $$ (i, j)
      else if i = j then 
        if i = k - 1 then 
          ((d_of dmu (Suc k)) * (d_of dmu (k-1)) + dmu $$ (k, k - 1) * dmu $$ (k, k - 1)) 
            div (d_of dmu k)
        else (d_of dmu (Suc i))
      else dmu $$ (i, j))
    ))"
  and dmu'_mod_def: "dmu'_mod = mat m m (λ(i, j). (
        if j < i  (j = k  j = k - 1) then 
          dmu' $$ (i, j) symmod (p * (d_of dmu' j) * (d_of dmu' (Suc j)))
        else dmu' $$ (i, j)))"
shows "(fs'. LLL_invariant_mod_weak fs' mfs' dmu'_mod p first b 
        LLL_measure (k-1) fs' < LLL_measure k fs 
        (LLL_invariant_mod fs mfs dmu p first b k  LLL_invariant_mod fs' mfs' dmu'_mod p first b (k-1)))" 
proof - 
  define fs' where "fs' = fs[k := fs ! (k - 1), k - 1 := fs ! k]"
  have pgtz: "p > 0" and p1: "p > 1" using LLL_invD_modw[OF Linvmw] by auto
  have invw: "LLL_invariant_weak fs" using LLL_invD_modw[OF Linvmw] LLL_invariant_weak_def by simp
  note swap_main = basis_reduction_swap_main(3-)[OF invw disjI2[OF mu_F1_i] k k0 norm_ineq fs'_def]
  note ddμ_swap = d_dμ_swap[OF invw disjI2[OF mu_F1_i] k k0 norm_ineq fs'_def]
  have invw': "LLL_invariant_weak fs'" using fs'_def assms invw basis_reduction_swap_main(1) by simp
  have 02: "LLL_measure k fs > LLL_measure (k - 1) fs'" by fact
  have 03: " i j. i < m  j < i fs' i j = (
        if i = k - 1 thenfs k j
        else if i = k  j  k - 1 thenfs (k - 1) j
        else if i > k  j = k then
           (d fs (Suc k) *fs i (k - 1) -fs k (k - 1) *fs i j) div d fs k
        else if i > k  j = k - 1 then 
           (fs k (k - 1) *fs i j +fs i k * d fs (k - 1)) div d fs k
        elsefs i j)"
    using ddμ_swap by auto
  have 031: "i. i < k-1  gso fs' i = gso fs i" 
    using swap_main(2) k k0 by auto
  have 032: " ii. ii  m  of_int (d fs' ii) = (if ii = k then 
           sq_norm (gso fs' (k - 1)) / sq_norm (gso fs (k - 1)) * of_int (d fs k)
           else of_int (d fs ii))" 
    by fact 
  have gbnd: "g_bnd_mode first b fs'"
  proof (cases "first  m  0")
    case True
    have "sq_norm (gso fs' 0)  sq_norm (gso fs 0)" 
    proof (cases "k - 1 = 0")
      case False
      thus ?thesis using 031[of 0] by simp
    next
      case *: True
      have k_1: "k - 1 < m" using k by auto
      from * k0 have k1: "k = 1" by simp
      (* this is a copy of what is done in LLL.swap-main, should be made accessible in swap-main *)
      have "sq_norm (gso fs' 0)  abs (sq_norm (gso fs' 0))" by simp
      also have " = abs (sq_norm (gso fs 1) + μ fs 1 0 * μ fs 1 0 * sq_norm (gso fs 0))" 
        by (subst swap_main(3)[OF k_1, unfolded *], auto simp: k1)
      also have "  sq_norm (gso fs 1) + abs (μ fs 1 0) * abs (μ fs 1 0) * sq_norm (gso fs 0)"
        by (simp add: sq_norm_vec_ge_0)
      also have "  sq_norm (gso fs 1) + (1 / 2) * (1 / 2) * sq_norm (gso fs 0)" 
        using mu_F1_i[unfolded k1] 
        by (intro plus_right_mono mult_mono, auto)
      also have " < 1 / α * sq_norm (gso fs 0) + (1 / 2) * (1 / 2) * sq_norm (gso fs 0)" 
        by (intro add_strict_right_mono, insert norm_ineq[unfolded mult.commute[of α],
          THEN mult_imp_less_div_pos[OF α0(1)]] k1, auto)
      also have " = reduction * sq_norm (gso fs 0)" unfolding reduction_def
        using α0 by (simp add: ring_distribs add_divide_distrib)
      also have "  1 * sq_norm (gso fs 0)" using reduction(2)
        by (intro mult_right_mono, auto)
      finally show ?thesis by simp
    qed
    thus ?thesis using LLL_invD_modw(14)[OF Linvmw] True
      unfolding g_bnd_mode_def by auto
  next
    case False
    from LLL_invD_modw(14)[OF Linvmw] False have "g_bnd b fs" unfolding g_bnd_mode_def by auto
    hence "g_bnd b fs'" using g_bnd_swap[OF k k0 invw mu_F1_i norm_ineq fs'_def] by simp
    thus ?thesis using False unfolding g_bnd_mode_def by auto
  qed
  note d_of = d_of_weak[OF Linvmw]
  have 033: " i. i < m fs' i i = (
            if i = k - 1 then 
             ((d_of dmu (Suc k)) * (d_of dmu (k-1)) + dmu $$ (k, k - 1) * dmu $$ (k, k - 1)) 
                div (d_of dmu k)
            else (d_of dmu (Suc i)))"  
  proof -
    fix i
    assume i: "i < m"
    have "dμ fs' i i = d fs' (Suc i)" using ddμ i by simp
    also have " = (if i = k - 1 then 
          (d fs (Suc k) * d fs (k - 1) +fs k (k - 1) *fs k (k - 1)) div d fs k 
        else d fs (Suc i))"
      by (subst ddμ_swap, insert ddμ k0 i, auto)
    also have " = (if i = k - 1 then 
        ((d_of dmu (Suc k)) * (d_of dmu (k-1)) + dmu $$ (k, k - 1) * dmu $$ (k, k - 1)) 
          div (d_of dmu k)
       else (d_of dmu (Suc i)))" (is "_ = ?r") 
      using d_of i k LLL_invD_modw(7)[OF Linvmw] by auto
    finally show "dμ fs' i i = ?r" .
  qed
  have 04: "lin_indep fs'" "length fs' = m" "lattice_of fs' = L" using LLL_inv_wD[OF invw'] by auto
  define I where "I = {(i, j). i < m  j < i  (j = k  j = k - 1)}"
  then have Isubs: "I  {(i,j). i < m  j < i}" using k k0 by auto
  obtain fs'' where 
    05: "lattice_of fs'' = L" and
    06: "map (map_vec (λ x. x symmod p)) fs'' = map (map_vec (λ x. x symmod p)) fs'" and
    07: "lin_indep fs''" and
    08: "length fs'' = m" and
    09: "( k < m. gso fs'' k = gso fs' k)" and
    10: "( k  m. d fs'' k = d fs' k)" and
    11: "( i' < m.  j' < m.fs'' i' j' = 
           (if (i',j')  I thenfs' i' j' symmod (p * d fs' j' * d fs' (Suc j')) elsefs' i' j'))"
    using mod_finite_set[OF 04(1) 04(2) Isubs 04(3) pgtz] by blast
  have 13: "length mfs' = m" using mfs'_def LLL_invD_modw(1)[OF Linvmw] by simp (* invariant requirement *)
  have 14: "map (map_vec (λ x. x symmod p)) fs'' = mfs'"  (* invariant requirement *)
    using 06 fs'_def k k0 04(2) LLL_invD_modw(5)[OF Linvmw]
    by (metis (no_types, lifting) length_list_update less_imp_diff_less map_update mfs'_def nth_map)
  have "LLL_measure (k - 1) fs'' = LLL_measure (k - 1) fs'" using 10 LLL_measure_def logD_def D_def by simp
  then have 15: "LLL_measure (k - 1) fs'' < LLL_measure k fs" using 02 by simp (* goal *)
  {
    fix i' j'
    assume i'j': "i'<m" "j'<i'" 
      and neq: "j'  k" "j'  k - 1"
    hence j'k: "j'  k" "Suc j'  k" using k0 by auto
    hence "d fs'' j' = d fs j'" "d fs'' (Suc j') = d fs (Suc j')" 
      using k < m i'j' k0
        10[rule_format, of j'] 032[rule_format, of j']
        10[rule_format, of "Suc j'"] 032[rule_format, of "Suc j'"] 
      by auto
  } note d_id = this

  have 16: "i'<m. j'<i'. ¦fs'' i' j'¦ < p * d fs'' j' * d fs'' (Suc j')" (* invariant requirement *)
  proof -
    {
      fix i' j'
      assume i'j': "i'<m" "j'<i'"
      have "¦fs'' i' j'¦ < p * d fs'' j' * d fs'' (Suc j')"
      proof (cases "(i',j')  I")
        case True
        define pdd where "pdd = (p * d fs' j' * d fs' (Suc j'))"
        have pdd_pos: "pdd > 0" using pgtz i'j' LLL_d_pos[OF invw'] pdd_def by simp
        have "dμ fs'' i' j' =fs' i' j' symmod pdd" using True 11 i'j' pdd_def by simp
        then have "¦fs'' i' j'¦ < pdd" using True 11 i'j' pdd_pos sym_mod_abs by simp
        then show ?thesis unfolding pdd_def using 10 i'j' by simp
      next
        case False
        from False[unfolded I_def] i'j' have neg: "j'  k" "j'  k - 1" by auto
        
        consider (1) "i' = k - 1  i' = k" | (2) "¬ (i' = k - 1  i' = k)"  
          using False i'j' unfolding I_def by linarith
        thus ?thesis
        proof cases
          case **: 1
          let ?i'' = "if i' = k - 1 then k else k -1" 
          from ** neg i'j' have i'': "?i'' < m" "j' < ?i''" using k0 k by auto
          have "dμ fs'' i' j' =fs' i' j'" using 11 False i'j' by simp
          also have " =fs ?i'' j'" unfolding 03[OF i' < m j' < i']
            using ** neg by auto
          finally show ?thesis using LLL_invD_modw(6)[OF Linvmw, rule_format, OF i''] unfolding d_id[OF i'j' neg] by auto
        next
          case **: 2
          hence neq: "j'  k" "j'  k - 1" using False k k0 i'j' unfolding I_def by auto
          have "dμ fs'' i' j' =fs' i' j'" using 11 False i'j' by simp
          also have " =fs i' j'" unfolding 03[OF i' < m j' < i'] using ** neq by auto
          finally show ?thesis using LLL_invD_modw(6)[OF Linvmw, rule_format, OF i'j'] using d_id[OF i'j' neq] by auto
        qed
      qed
    }
    then show ?thesis by simp
  qed
  have 17: "i'<m. j'<m.fs'' i' j' = dmu'_mod $$ (i', j')" (* invariant requirement *)
  proof -
    {
      fix i' j'
      assume i'j': "i'<m" "j'<i'"
      have d'dmu': "j' < m. d fs' (Suc j') = dmu' $$ (j', j')" using ddμ dmu'_def 033 by simp
      have eq': "dμ fs' i' j' = dmu' $$ (i', j')"
      proof -
        have t00: "dμ fs k j' = dmu $$ (k, j')" and
          t01: "dμ fs (k - 1) j' =  dmu $$ (k - 1, j')" and
          t04: "dμ fs k (k - 1) = dmu $$ (k, k - 1)" and
          t05: "dμ fs i' k = dmu $$ (i', k)"
          using LLL_invD_modw(7)[OF Linvmw] i'j' k ddμ k0 by auto 
        have t03: "d fs k =fs (k-1) (k-1)" using k0 k by (metis LLL.ddμ Suc_diff_1 lessI not_gr_zero)
        have t06: "d fs (k - 1) = (d_of dmu (k-1))" using d_of k by auto
        have t07: "d fs k = (d_of dmu k)" using d_of k by auto
        have j': "j' < m" using i'j' by simp
        have "dμ fs' i' j' = (if i' = k - 1 then 
                   dmu $$ (k, j')
                else if i' = k  j'  k - 1 then 
                   dmu $$ (k - 1, j')
                else if i' > k  j' = k then
                   (dmu $$ (k, k) * dmu $$ (i', k - 1) - dmu $$ (k, k - 1) * dmu $$ (i', j')) div (d_of dmu k)
                else if i' > k  j' = k - 1 then 
                   (dmu $$ (k, k - 1) * dmu $$ (i', j') + dmu $$ (i', k) * d fs (k - 1)) div (d_of dmu k)
                else dmu $$ (i', j'))"
          using ddμ k t00 t01 t03 LLL_invD_modw(7)[OF Linvmw] k i'j' j' 03 t07 by simp
        then show ?thesis using dmu'_def i'j' j' t06 t07 by (simp add: d_of_def)
      qed
      have "dμ fs'' i' j' = dmu'_mod $$ (i', j')"
      proof (cases "(i',j')  I")
        case i'j'I: True
        have j': "j' < m" using i'j' by simp
        show ?thesis
        proof -
          have "dmu'_mod $$ (i',j') = dmu' $$ (i',j') 
                  symmod (p * (d_of dmu' j') * (d_of dmu' (Suc j')))"
            using dmu'_mod_def i'j' i'j'I I_def by simp
          also have "d_of dmu' j' = d fs' j'" 
            using j' d'dmu' d_def Suc_diff_1 less_imp_diff_less unfolding d_of_def 
            by (cases j', auto)
          finally have "dmu'_mod $$ (i',j') = dmu' $$ (i',j') symmod (p * d fs' j' * d fs' (Suc j'))"
            using ddμ[OF j'] d'dmu' j' by (auto simp: d_of_def)
          then show ?thesis using i'j'I 11 i'j' eq' by simp
        qed
      next
        case False
        have "dμ fs'' i' j' =fs' i' j'" using False 11 i'j' by simp
        also have " = dmu' $$ (i', j')" unfolding eq' ..
        finally show ?thesis unfolding dmu'_mod_def using False[unfolded I_def] i'j' by auto
      qed
    }
    moreover have "i' j'. i' < m  j' < m  i' = j' fs'' i' j' = dmu'_mod $$ (i', j')" 
      using ddμ dmu'_def 033 10 dmu'_mod_def 11 I_def by simp
    moreover {
      fix i' j'
      assume i'j'': "i' < m" "j' < m" "i' < j'"
      then have μz: fs'' i' j' = 0" by (simp add: gram_schmidt_fs.μ.simps)
      have "dmu'_mod $$ (i',j') = dmu' $$ (i',j')" using dmu'_mod_def i'j'' by auto
      also have " =fs i' j'" using LLL_invD_modw(7)[OF Linvmw] i'j'' dmu'_def by simp
      also have " = 0" using dμ_def i'j'' by (simp add: gram_schmidt_fs.μ.simps)
      finally have "dμ fs'' i' j' =  dmu'_mod $$ (i',j')" using μz d_def i'j'' dμ_def by simp
    }
    ultimately show ?thesis by (meson nat_neq_iff)
  qed
  from gbnd 09 have g_bnd: "g_bnd_mode first b fs''" using g_bnd_mode_cong[of fs' fs''] by auto
  {
    assume Linv: "LLL_invariant_mod fs mfs dmu p first b k"
    have 00: "LLL_invariant_weak' k fs" using LLL_invD_mod[OF Linv] LLL_invI_weak by simp
    note swap_weak' = basis_reduction_swap_weak'[OF 00 k k0 mu_F1_i norm_ineq fs'_def]
    have 01: "LLL_invariant_weak' (k - 1) fs'" by fact
    have 12: "weakly_reduced fs'' (k-1)" (* invariant requirement *)
      using 031 09 k LLL_invD_weak(8)[OF 00] unfolding gram_schmidt_fs.weakly_reduced_def by simp
    have "LLL_invariant_mod fs'' mfs' dmu'_mod p first b (k-1)" 
      using LLL_invI_mod[OF 13 _ 08 05 07 12 14 16 17 p1 g_bnd LLL_invD_mod(17)[OF Linv]] k by simp
  }
  moreover have "LLL_invariant_mod_weak fs'' mfs' dmu'_mod p first b"
    using LLL_invI_modw[OF 13 08 05 07 14 16 17 p1 g_bnd LLL_invD_modw(15)[OF Linvmw]] by simp
  ultimately show ?thesis using 15 by auto
qed

lemma dmu_quot_is_round_of_μ:
  assumes Linv: "LLL_invariant_mod fs mfs dmu p first b i'"
    and c: "c = round_num_denom (dmu $$ (i,j)) (d_of dmu (Suc j))" 
    and i: "i < m"
    and j: "j < i"
  shows "c = round(μ fs i j)" 
proof -
  have Linvw: "LLL_invariant_weak' i' fs" using LLL_invD_mod[OF Linv] LLL_invI_weak by simp
  have j2: "j < m" using i j by simp
  then have j3: "Suc j  m" by simp
  have μ1: fs j j = 1" using i j by (meson gram_schmidt_fs.μ.elims less_irrefl_nat)
  have inZ: "rat_of_int (d fs (Suc j)) * μ fs i j  " using fs_int_indpt.fs_int_mu_d_Z_m_m i j
      LLL_invD_mod(5)[OF Linv] LLL_invD_weak(2) Linvw d_def fs_int.d_def fs_int_indpt.intro by auto
  have "c = round(rat_of_int (fs i j) / rat_of_int (fs j j))" using LLL_invD_mod(9) Linv i j c 
    by (simp add: round_num_denom d_of_def)
  then show ?thesis using LLL_d_pos[OF LLL_invw'_imp_w[OF Linvw] j3] j i inZ dμ_def μ1 by simp
qed

lemma dmu_quot_is_round_of_μ_weak:
  assumes Linv: "LLL_invariant_mod_weak fs mfs dmu p first b"
    and c: "c = round_num_denom (dmu $$ (i,j)) (d_of dmu (Suc j))" 
    and i: "i < m"
    and j: "j < i"
  shows "c = round(μ fs i j)" 
proof -
  have Linvww: "LLL_invariant_weak fs" using LLL_invD_modw[OF Linv] LLL_invariant_weak_def by simp
  have j2: "j < m" using i j by simp
  then have j3: "Suc j  m" by simp
  have μ1: fs j j = 1" using i j by (meson gram_schmidt_fs.μ.elims less_irrefl_nat)
  have inZ: "rat_of_int (d fs (Suc j)) * μ fs i j  " using fs_int_indpt.fs_int_mu_d_Z_m_m i j
      LLL_invD_modw[OF Linv] d_def fs_int.d_def fs_int_indpt.intro by auto
  have "c = round(rat_of_int (fs i j) / rat_of_int (fs j j))" using LLL_invD_modw(7) Linv i j c 
    by (simp add: round_num_denom d_of_def)
  then show ?thesis using LLL_d_pos[OF Linvww j3] j i inZ dμ_def μ1 by simp
qed  

lemma basis_reduction_mod_add_row: assumes 
  Linv: "LLL_invariant_mod_weak fs mfs dmu p first b" 
  and res: "basis_reduction_mod_add_row p mfs dmu i j = (mfs', dmu')" 
  and i: "i < m"
  and j: "j < i"
  and igtz: "i  0"
shows "(fs'. LLL_invariant_mod_weak fs' mfs' dmu' p first b 
        LLL_measure i fs' = LLL_measure i fs 
        (μ_small_row i fs (Suc j)  μ_small_row i fs' j) 
        ¦μ fs' i j¦  1 / 2 
        (i' j'. i' < i  j'  i'  μ fs' i' j' = μ fs i' j') 
        (LLL_invariant_mod fs mfs dmu p first b i  LLL_invariant_mod fs' mfs' dmu' p first b i) 
        (ii  m. d fs' ii = d fs ii))"
proof -
  define c where "c = round_num_denom (dmu $$ (i,j)) (d_of dmu (Suc j))" 
  then have c: "c = round(μ fs i j)" using dmu_quot_is_round_of_μ_weak[OF Linv c_def i j] by simp
  show ?thesis
  proof (cases "c = 0")
    case True
    then have pair_id: "(mfs', dmu') = (mfs, dmu)" 
      using res c_def unfolding basis_reduction_mod_add_row_def Let_def by auto
    moreover have "¦μ fs i j¦  inverse 2" using c[symmetric, unfolded True] 
      by (simp add: round_def, linarith)
    moreover then have "(μ_small_row i fs (Suc j)  μ_small_row i fs j)" 
      unfolding μ_small_row_def using Suc_leI le_neq_implies_less by blast
    ultimately show ?thesis using Linv pair_id by auto
  next
    case False
    then have pair_id: "(mfs', dmu') = (mfs[i := map_vec (λx. x symmod p) (mfs ! i - c v mfs ! j)],
                mat m m (λ(i', j'). if i' = i  j'  j
                  then if j' = j then dmu $$ (i, j') - c * dmu $$ (j, j')
                       else (dmu $$ (i,j') - c * dmu $$ (j,j')) 
                              symmod (p * (d_of dmu j') * (d_of dmu (Suc j')))
                  else dmu $$ (i', j')))" 
      using res c_def unfolding basis_reduction_mod_add_row_def Let_def by auto
    then have mfs': "mfs' = mfs[i := map_vec (λx. x symmod p) (mfs ! i - c v mfs ! j)]"
      and dmu': "dmu' = mat m m (λ(i', j'). if i' = i  j'  j
                  then if j' = j then dmu $$ (i, j') - c * dmu $$ (j, j')
                       else (dmu $$ (i,j') - c * dmu $$ (j,j')) 
                              symmod (p * (d_of dmu j') * (d_of dmu (Suc j')))
                  else dmu $$ (i', j'))" by auto
    show ?thesis using basis_reduction_mod_add_row_main[OF Linv i j c mfs' dmu'] by blast
  qed
qed

lemma basis_reduction_mod_swap: assumes
  Linv: "LLL_invariant_mod_weak fs mfs dmu p first b"
  and mu: "¦μ fs k (k-1)¦  1 / 2"
  and res: "basis_reduction_mod_swap p mfs dmu k = (mfs', dmu'_mod)" 
  and cond: "sq_norm (gso fs (k - 1)) > α * sq_norm (gso fs k)"
  and i: "k < m" "k  0" 
shows "(fs'. LLL_invariant_mod_weak fs' mfs' dmu'_mod p first b 
        LLL_measure (k - 1) fs' < LLL_measure k fs 
        (LLL_invariant_mod fs mfs dmu p first b k  LLL_invariant_mod fs' mfs' dmu'_mod p first b (k-1)))"
  using res[unfolded basis_reduction_mod_swap_def basis_reduction_mod_swap_dmu_mod_def] 
    basis_reduction_mod_swap_main[OF Linv i mu cond] by blast

lemma basis_reduction_adjust_mod: assumes 
  Linv: "LLL_invariant_mod_weak fs mfs dmu p first b" 
  and res: "basis_reduction_adjust_mod p first mfs dmu = (p', mfs', dmu', g_idx')" 
shows "(fs' b'. (LLL_invariant_mod fs mfs dmu p first b i  LLL_invariant_mod fs' mfs' dmu' p' first b' i) 
       LLL_invariant_mod_weak fs' mfs' dmu' p' first b' 
       LLL_measure i fs' = LLL_measure i fs)"
proof (cases " g_idx. basis_reduction_adjust_mod p first mfs dmu = (p, mfs, dmu, g_idx)")
  case True
  thus ?thesis using res Linv by auto
next
  case False
  obtain b' g_idx where norm: "compute_max_gso_norm first dmu = (b', g_idx)" by force
  define p'' where "p'' = compute_mod_of_max_gso_norm first b'" 
  define d_vec where "d_vec = vec (Suc m) (λi. d_of dmu i)" 
  define mfs'' where "mfs'' = map (map_vec (λx. x symmod p'')) mfs"  
  define dmu'' where "dmu'' = mat m m (λ(i, j).
                   if j < i then dmu $$ (i, j) symmod (p'' * d_vec $ j * d_vec $ Suc j)
                   else dmu $$ (i, j))" 
  note res = res False
  note res = res[unfolded basis_reduction_adjust_mod.simps Let_def norm split, 
      folded p''_def, folded d_vec_def mfs''_def, folded dmu''_def]
  from res have pp': "p'' < p" and id: "dmu' = dmu''" "mfs' = mfs''" "p' = p''" "g_idx' = g_idx"
    by (auto split: if_splits)
  define I where "I = {(i',j'). i' < m  j' < i'}"
  note inv = LLL_invD_modw[OF Linv]
  from inv(4) have lin: "gs.lin_indpt_list (RAT fs)" .
  from inv(3) have lat: "lattice_of fs = L" .
  from inv(2) have len: "length fs = m" .
  have weak: "LLL_invariant_weak fs" using Linv
    by (auto simp: LLL_invariant_mod_weak_def LLL_invariant_weak_def)
  from compute_max_gso_norm[OF _ weak, of dmu first, unfolded norm] inv(7)
  have bnd: "g_bnd_mode first b' fs" and b': "b'  0" "m = 0  b' = 0" by auto
  from compute_mod_of_max_gso_norm[OF b' p''_def] 
  have p'': "0 < p''" "1 < p''" "mod_invariant b' p'' first" 
    by auto
  obtain fs' where 
    01: "lattice_of fs' = L" and
    02: "map (map_vec (λ x. x symmod p'')) fs' = map (map_vec (λ x. x symmod p'')) fs" and
    03: "lin_indep fs'" and
    04: "length fs' = m" and
    05: "( k < m. gso fs' k = gso fs k)" and
    06: "( k  m. d fs' k = d fs k)" and
    07: "( i' < m.  j' < m.fs' i' j' = 
      (if (i',j')  I thenfs i' j' symmod (p'' * d fs j' * d fs (Suc j')) elsefs i' j'))"
    using mod_finite_set[OF lin len _ lat, of I] I_def p'' by blast
  from bnd 05 have bnd: "g_bnd_mode first b' fs'" using g_bnd_mode_cong[of fs fs'] by auto
  have D: "D fs = D fs'" unfolding D_def using 06 by auto  


  have Linv': "LLL_invariant_mod_weak fs' mfs'' dmu'' p'' first b'"
  proof (intro LLL_invI_modw p'' 04 03 01 bnd)
    {
      have "mfs'' = map (map_vec (λx. x symmod p'')) mfs" by fact
      also have " = map (map_vec (λx. x symmod p'')) (map (map_vec (λx. x symmod p)) fs)" 
        using inv by simp
      also have " = map (map_vec (λx. x symmod p symmod p'')) fs" by auto
      also have "(λ x. x symmod p symmod p'') = (λ x. x symmod p'')" 
      proof (intro ext)
        fix x
        from ‹mod_invariant b p first[unfolded mod_invariant_def] obtain e where 
          p: "p = log_base ^ e" by auto
        from p''[unfolded mod_invariant_def] obtain e' where
          p'': "p'' = log_base ^ e'" by auto
        from pp'[unfolded p p''] log_base have "e'  e" by simp
        hence dvd: "p'' dvd p" unfolding p p'' using log_base by (metis le_imp_power_dvd)
        thus "x symmod p symmod p'' = x symmod p''"  
          by (intro sym_mod_sym_mod_cancel)
      qed
      finally show "map (map_vec (λx. x symmod p'')) fs' = mfs''" unfolding 02 ..
    }
    thus "length mfs'' = m" using 04 by auto
    show "i'<m. j'<i'. ¦fs' i' j'¦ < p'' * d fs' j' * d fs' (Suc j')"
    proof -
      {
        fix i' j'
        assume i'j': "i' < m" "j' < i'"
        then have "dμ fs' i' j' =fs i' j' symmod (p'' * d fs' j' * d fs' (Suc j'))"
          using 07 06 unfolding I_def by simp
        then have "¦fs' i' j'¦ < p'' * d fs' j' * d fs' (Suc j')" 
          using sym_mod_abs p'' LLL_d_pos[OF weak] mult_pos_pos
          by (smt "06" i'j' less_imp_le_nat less_trans_Suc nat_SN.gt_trans)
      }
      then show ?thesis by simp
    qed
    from inv(7) have dmu: "i' < m  j' < m  dmu $$ (i', j') =fs i' j'" for i' j'
      by auto
    note d_of = d_of_weak[OF Linv]
    have dvec: "i  m  d_vec $ i = d fs i" for i unfolding d_vec_def using d_of by auto
    show "i'<m. j'<m.fs' i' j' = dmu'' $$ (i', j')" 
      using 07 unfolding dmu''_def I_def 
      by (auto simp: dmu dvec)
  qed

  moreover 
  {
    assume linv: "LLL_invariant_mod fs mfs dmu p first b i" 
    note inv = LLL_invD_mod[OF linv]
    hence i: "i  m" by auto
    have norm: "j < m  gso fs j2 = gso fs' j2" for j
      using 05 by auto
    have "weakly_reduced fs i = weakly_reduced fs' i" 
      unfolding gram_schmidt_fs.weakly_reduced_def using i
      by (intro all_cong arg_cong2[where f = "(≤)"] arg_cong[where f = "λ x. _ * x"] norm, auto)
    with inv have "weakly_reduced fs' i" by auto
    hence "LLL_invariant_mod fs' mfs'' dmu'' p'' first b' i" using inv         
      by (intro LLL_invI_mod LLL_invD_modw[OF Linv'])
  }

  moreover have "LLL_measure i fs' = LLL_measure i fs" 
    unfolding LLL_measure_def logD_def D ..
  ultimately show ?thesis unfolding id by blast
qed

lemma alpha_comparison: assumes 
  Linv: "LLL_invariant_mod_weak fs mfs dmu p first b"
  and alph: "quotient_of α = (num, denom)" 
  and i: "i < m" 
  and i0: "i  0" 
shows "(d_of dmu i * d_of dmu i * denom  num * d_of dmu (i - 1) * d_of dmu (Suc i))
  = (sq_norm (gso fs (i - 1))  α * sq_norm (gso fs i))" 
proof - 
  note inv = LLL_invD_modw[OF Linv]
  interpret fs_indep: fs_int_indpt n fs
    by (unfold_locales, insert inv, auto)
  from inv(2) i have ifs: "i < length fs" by auto
  note d_of_fs = d_of_weak[OF Linv]
  show ?thesis 
    unfolding fs_indep.d_sq_norm_comparison[OF alph ifs i0, symmetric]
    by (subst (1 2 3 4) d_of_fs, use i d_def fs_indep.d_def in auto)
qed

lemma basis_reduction_adjust_swap_add_step: assumes 
  Linv: "LLL_invariant_mod_weak fs mfs dmu p first b" 
  and res: "basis_reduction_adjust_swap_add_step p first mfs dmu g_idx i = (p', mfs', dmu', g_idx')" 
  and alph: "quotient_of α = (num, denom)" 
  and ineq: "¬ (d_of dmu i * d_of dmu i * denom
               num * d_of dmu (i - 1) * d_of dmu (Suc i))" 
  and i: "i < m" 
  and i0: "i  0" 
shows "fs' b'. LLL_invariant_mod_weak fs' mfs' dmu' p' first b' 
        LLL_measure (i - 1) fs' < LLL_measure i fs 
        LLL_measure (m - 1) fs' < LLL_measure (m - 1) fs 
        (LLL_invariant_mod fs mfs dmu p first b i  
         LLL_invariant_mod fs' mfs' dmu' p' first b' (i - 1))"
proof -
  obtain mfs0 dmu0 where add: "basis_reduction_mod_add_row p mfs dmu i (i-1) = (mfs0, dmu0)" by force
  obtain mfs1 dmu1 where swap: "basis_reduction_mod_swap p mfs0 dmu0 i = (mfs1, dmu1)" by force
  note res = res[unfolded basis_reduction_adjust_swap_add_step_def Let_def add split swap]
  from i0 have ii: "i - 1 < i" by auto
  from basis_reduction_mod_add_row[OF Linv add i ii i0]
  obtain fs0 where Linv0: "LLL_invariant_mod_weak fs0 mfs0 dmu0 p first b" 
    and meas0: "LLL_measure i fs0 = LLL_measure i fs" 
    and small: "¦μ fs0 i (i - 1)¦  1 / 2" 
    and Linv0': "LLL_invariant_mod fs mfs dmu p first b i  LLL_invariant_mod fs0 mfs0 dmu0 p first b i" 
    by blast
  {
    have id: "d_of dmu0 i = d_of dmu i" "d_of dmu0 (i - 1) = d_of dmu (i - 1)"
      "d_of dmu0 (Suc i) = d_of dmu (Suc i)"
      using i i0 add[unfolded basis_reduction_mod_add_row_def Let_def]
      by (auto split: if_splits simp: d_of_def)
    from ineq[folded id, unfolded alpha_comparison[OF Linv0 alph i i0]]
    have "gso fs0 (i - 1)2 > α * gso fs0 i2" by simp
  } note ineq = this
  from Linv have "LLL_invariant_weak fs" 
    by (auto simp: LLL_invariant_weak_def LLL_invariant_mod_weak_def)
  from basis_reduction_mod_swap[OF Linv0 small swap ineq i i0, unfolded meas0] Linv0'
  obtain fs1 where Linv1: "LLL_invariant_mod_weak fs1 mfs1 dmu1 p first b"
    and meas1: "LLL_measure (i - 1) fs1 < LLL_measure i fs" 
    and Linv1': "LLL_invariant_mod fs mfs dmu p first b i  LLL_invariant_mod fs1 mfs1 dmu1 p first b (i - 1)" 
    by auto
  show ?thesis
  proof (cases "i - 1 = g_idx")
    case False
    with res have id: "p' = p" "mfs' = mfs1" "dmu' = dmu1" "g_idx' = g_idx" by auto
    show ?thesis unfolding id using Linv1' meas1 Linv1 by (intro exI[of _ fs1] exI[of _ b], auto simp: LLL_measure_def)
  next
    case True
    with res have adjust: "basis_reduction_adjust_mod p first mfs1 dmu1 = (p', mfs', dmu', g_idx')" by simp
    from basis_reduction_adjust_mod[OF Linv1 adjust, of "i - 1"] Linv1'
    obtain fs' b' where Linvw: "LLL_invariant_mod_weak fs' mfs' dmu' p' first b'"
      and Linv: "LLL_invariant_mod fs mfs dmu p first b i  LLL_invariant_mod fs' mfs' dmu' p' first b' (i - 1)"
      and meas: "LLL_measure (i - 1) fs' = LLL_measure (i - 1) fs1" 
      by blast
    note meas = meas1[folded meas]
    from meas have meas': "LLL_measure (m - 1) fs' < LLL_measure (m - 1) fs" 
      unfolding LLL_measure_def using i by auto
    show ?thesis
      by (intro exI conjI impI, rule Linvw, rule meas, rule meas', rule Linv) 
  qed
qed


lemma basis_reduction_mod_step: assumes 
  Linv: "LLL_invariant_mod fs mfs dmu p first b i" 
  and res: "basis_reduction_mod_step p first mfs dmu g_idx i j = (p', mfs', dmu', g_idx', i', j')" 
  and i: "i < m" 
shows "fs' b'. LLL_measure i' fs' < LLL_measure i fs  LLL_invariant_mod fs' mfs' dmu' p' first b' i'"
proof -
  note res = res[unfolded basis_reduction_mod_step_def Let_def]
  from Linv have Linvw: "LLL_invariant_mod_weak fs mfs dmu p first b" 
    by (auto simp: LLL_invariant_mod_weak_def LLL_invariant_mod_def)
  show ?thesis
  proof (cases "i = 0")
    case True
    then have ids: "mfs' = mfs" "dmu' = dmu" "i' = Suc i" "p' = p" using res by auto
    have "LLL_measure i' fs < LLL_measure i fs  LLL_invariant_mod fs mfs' dmu' p first b i'"
      using increase_i_mod[OF Linv i] True res ids inv by simp
    then show ?thesis using res ids inv by auto
  next
    case False
    hence id: "(i = 0) = False" by auto
    obtain num denom where alph: "quotient_of α = (num, denom)" by force
    note res = res[unfolded id if_False alph split]
    let ?comp = "d_of dmu i * d_of dmu i * denom  num * d_of dmu (i - 1) * d_of dmu (Suc i)" 
    show ?thesis
    proof (cases ?comp)
      case False
      hence id: "?comp = False" by simp
      note res = res[unfolded id if_False]
      let ?step = "basis_reduction_adjust_swap_add_step p first mfs dmu g_idx i" 
      from res have step: "?step = (p', mfs', dmu', g_idx')" 
        and i': "i' = i - 1" 
        by (cases ?step, auto)+
      from basis_reduction_adjust_swap_add_step[OF Linvw step alph False i i  0] Linv
      show ?thesis unfolding i' by blast
    next
      case True
      hence id: "?comp = True" by simp
      note res = res[unfolded id if_True]
      from res have ids: "p' = p" "mfs' = mfs" "dmu' = dmu" "i' = Suc i" by auto
      from True alpha_comparison[OF Linvw alph i False]
      have ineq: "sq_norm (gso fs (i - 1))  α * sq_norm (gso fs i)" by simp
      from increase_i_mod[OF Linv i ineq]
      show ?thesis unfolding ids by auto
    qed
  qed
qed

lemma basis_reduction_mod_main: assumes "LLL_invariant_mod fs mfs dmu p first b i" 
  and res: "basis_reduction_mod_main p first mfs dmu g_idx i j = (p', mfs', dmu')" 
shows "fs' b'. LLL_invariant_mod fs' mfs' dmu' p' first b' m" 
  using assms
proof (induct "LLL_measure i fs" arbitrary: i mfs dmu j p b fs g_idx rule: less_induct)
  case (less i fs mfs dmu j p b g_idx)
  hence fsinv: "LLL_invariant_mod fs mfs dmu p first b i" by auto
  note res = less(3)[unfolded basis_reduction_mod_main.simps[of p first mfs dmu g_idx i j]]
  note inv = less(2)
  note IH = less(1)
  show ?case
  proof (cases "i < m")
    case i: True
    obtain p' mfs' dmu' g_idx' i' j' where step: "basis_reduction_mod_step p first mfs dmu g_idx i j = (p', mfs', dmu', g_idx', i', j')" 
      (is "?step = _") by (cases ?step, auto)
    then obtain fs' b' where Linv: "LLL_invariant_mod fs' mfs' dmu' p' first b' i'" 
      and decr: "LLL_measure i' fs' < LLL_measure i fs"
      using basis_reduction_mod_step[OF fsinv step i] i fsinv by blast 
    note res = res[unfolded step split]
    from res i show ?thesis using IH[OF decr Linv] by auto
  next
    case False
    with LLL_invD_mod[OF fsinv] res have i: "i = m" "p' = p" by auto
    then obtain fs' b' where "LLL_invariant_mod fs' mfs' dmu' p first b' m" using False res fsinv by simp
    then show ?thesis using i by auto
  qed
qed

lemma compute_max_gso_quot_alpha: 
  assumes inv: "LLL_invariant_mod_weak fs mfs dmu p first b" 
  and max: "compute_max_gso_quot dmu = (msq_num, msq_denum, idx)"
  and alph: "quotient_of α = (num, denum)" 
  and cmp: "(msq_num * denum  > num * msq_denum) = cmp" 
  and m: "m > 1" 
shows "cmp  idx  0  idx < m  ¬ (d_of dmu idx * d_of dmu idx * denum
               num * d_of dmu (idx - 1) * d_of dmu (Suc idx))" 
  and "¬ cmp  LLL_invariant_mod fs mfs dmu p first b m" 
proof -
  from inv
  have fsinv: "LLL_invariant_weak fs" 
    by (simp add: LLL_invariant_mod_weak_def LLL_invariant_weak_def)
  define qt where "qt = (λi. ((d_of dmu (i + 1)) * (d_of dmu (i + 1)),
            (d_of dmu (i + 2)) * (d_of dmu i), Suc i))"
  define lst where "lst = (map (λi. qt i) [0..<(m-1)])"
  have msqlst: "(msq_num, msq_denum, idx) = max_list_rats_with_index lst"
    using max lst_def qt_def unfolding compute_max_gso_quot_def by simp
  have nz: "n d i. (n, d, i)  set lst  d > 0"
    unfolding lst_def qt_def using d_of_weak[OF inv] LLL_d_pos[OF fsinv] by auto
  have geq: "(n, d, i)  set lst. rat_of_int msq_num / of_int msq_denum  rat_of_int n / of_int d"
    using max_list_rats_with_index[of lst] nz msqlst by (metis (no_types, lifting) case_prodI2)
  have len: "length lst  1" using m unfolding lst_def by simp
  have inset: "(msq_num, msq_denum, idx)  set lst"
    using max_list_rats_with_index_in_set[OF msqlst[symmetric] len] nz by simp
  then have idxm: "idx  {1..<m}" using lst_def[unfolded qt_def] by auto
  then have idx0: "idx  0" and idx: "idx < m" by auto
  have 00: "(msq_num, msq_denum, idx)  = qt (idx - 1)" using lst_def inset qt_def by auto
  then have id_qt: "msq_num = d_of dmu idx * d_of dmu idx" "msq_denum = d_of dmu (Suc idx) * d_of dmu (idx - 1)" 
    unfolding qt_def by auto
  have "msq_denum = (d_of dmu (idx + 1)) * (d_of dmu (idx - 1))"
    using 00 unfolding qt_def by simp
  then have dengt0: "msq_denum > 0" using d_of_weak[OF inv] idxm LLL_d_pos[OF fsinv] by auto
  have αdengt0: "denum > 0" using alph by (metis quotient_of_denom_pos)
  from cmp[unfolded id_qt]
  have cmp: "cmp = (¬ (d_of dmu idx * d_of dmu idx * denum  num * d_of dmu (idx - 1) * d_of dmu (Suc idx)))" 
    by (auto simp: ac_simps)
  {
    assume cmp    
    from this[unfolded cmp] 
    show "idx  0  idx < m  ¬ (d_of dmu idx * d_of dmu idx * denum
               num * d_of dmu (idx - 1) * d_of dmu (Suc idx))" using idx0 idx by auto
  }
  {
    assume "¬ cmp" 
    from this[unfolded cmp] have small: "d_of dmu idx * d_of dmu idx * denum  num * d_of dmu (idx - 1) * d_of dmu (Suc idx)" by auto
    note d_pos = LLL_d_pos[OF fsinv]
    have gso: "k < m  sq_norm (gso fs k) = of_int (d fs (Suc k)) / of_int (d fs k)" for k using 
        LLL_d_Suc[OF fsinv, of k] d_pos[of k] by simp
    have gso_pos: "k < m  sq_norm (gso fs k) > 0" for k 
      using gso[of k] d_pos[of k] d_pos[of "Suc k"] by auto
    from small[unfolded alpha_comparison[OF inv alph idx idx0]]
    have alph: "sq_norm (gso fs (idx - 1))  α * sq_norm (gso fs idx)" .
    with gso_pos[OF idx] have alph: "sq_norm (gso fs (idx - 1)) / sq_norm (gso fs idx)  α" 
      by (metis mult_imp_div_pos_le)
    have weak: "weakly_reduced fs m" unfolding gram_schmidt_fs.weakly_reduced_def
    proof (intro allI impI, goal_cases)
      case (1 i)
      from idx have idx1: "idx - 1 < m" by auto
      from geq[unfolded lst_def]
      have mem: "(d_of dmu (Suc i) * d_of dmu (Suc i),
            d_of dmu (Suc (Suc i)) * d_of dmu i, Suc i)  set lst" 
        unfolding lst_def qt_def using 1 by auto
      have "sq_norm (gso fs i) / sq_norm (gso fs (Suc i)) = 
        of_int (d_of dmu (Suc i) * d_of dmu (Suc i)) / of_int (d_of dmu (Suc (Suc i)) * d_of dmu i)" 
        using gso idx0 d_of_weak[OF inv] 1 by auto
      also have "  rat_of_int msq_num / rat_of_int msq_denum" 
        using geq[rule_format, OF mem, unfolded split] by auto
      also have " = sq_norm (gso fs (idx - 1)) / sq_norm (gso fs idx)" 
        unfolding id_qt gso[OF idx] gso[OF idx1] using idx0 d_of_weak[OF inv] idx by auto
      also have "  α" by fact
      finally show "sq_norm (gso fs i)  α * sq_norm (gso fs (Suc i))" using gso_pos[OF 1]
        using pos_divide_le_eq by blast
    qed
    with inv show "LLL_invariant_mod fs mfs dmu p first b m" 
      by (auto simp: LLL_invariant_mod_weak_def LLL_invariant_mod_def)
  }
qed
  

lemma small_m: 
  assumes inv: "LLL_invariant_mod_weak fs mfs dmu p first b" 
  and m: "m  1" 
shows "LLL_invariant_mod fs mfs dmu p first b m" 
proof -
  have weak: "weakly_reduced fs m" unfolding gram_schmidt_fs.weakly_reduced_def using m
    by auto
  with inv show "LLL_invariant_mod fs mfs dmu p first b m" 
    by (auto simp: LLL_invariant_mod_weak_def LLL_invariant_mod_def)
qed

lemma basis_reduction_iso_main: assumes "LLL_invariant_mod_weak fs mfs dmu p first b"
  and res: "basis_reduction_iso_main p first mfs dmu g_idx j = (p', mfs', dmu')" 
shows "fs' b'. LLL_invariant_mod fs' mfs' dmu' p' first b' m" 
  using assms
proof (induct "LLL_measure (m-1) fs" arbitrary: fs mfs dmu j p b g_idx rule: less_induct)
  case (less fs mfs dmu j p b g_idx)
  have inv: "LLL_invariant_mod_weak fs mfs dmu p first b" using less by auto
  hence fsinv: "LLL_invariant_weak fs" 
    by (simp add: LLL_invariant_mod_weak_def LLL_invariant_weak_def)
  note res = less(3)[unfolded basis_reduction_iso_main.simps[of p first mfs dmu g_idx j]]
  note IH = less(1)
  obtain msq_num msq_denum idx where max: "compute_max_gso_quot dmu = (msq_num, msq_denum, idx)" 
    by (metis prod_cases3)
  obtain num denum where alph: "quotient_of α = (num, denum)" by force
  note res = res[unfolded max alph Let_def split]
  consider (small) "m  1" | (final) "m > 1" "¬ (num * msq_denum < msq_num * denum)" | (step) "m > 1" "num * msq_denum < msq_num * denum" 
    by linarith
  thus ?case
  proof cases
    case *: step
    obtain p1 mfs1 dmu1 g_idx1 where step: "basis_reduction_adjust_swap_add_step p first mfs dmu g_idx idx = (p1, mfs1, dmu1, g_idx1)"
      by (metis prod_cases4)
    from res[unfolded step split] * have res: "basis_reduction_iso_main p1 first mfs1 dmu1 g_idx1 (j + 1) = (p', mfs', dmu')" by auto
    from compute_max_gso_quot_alpha(1)[OF inv max alph refl *]
    have idx0: "idx  0" and idx: "idx < m" and cmp: "¬ d_of dmu idx * d_of dmu idx * denum  num * d_of dmu (idx - 1) * d_of dmu (Suc idx)" by auto
    from basis_reduction_adjust_swap_add_step[OF inv step alph cmp idx idx0] obtain fs1 b1 
      where inv1: "LLL_invariant_mod_weak fs1 mfs1 dmu1 p1 first b1" and meas: "LLL_measure (m - 1) fs1 < LLL_measure (m - 1) fs" 
      by auto
    from IH[OF meas inv1 res] show ?thesis .
  next
    case small
    with res small_m[OF inv] show ?thesis by auto
  next
    case final 
    from compute_max_gso_quot_alpha(2)[OF inv max alph refl final]
      final show ?thesis using res by auto
  qed
qed

lemma basis_reduction_mod_add_rows_loop_inv': assumes 
  fsinv: "LLL_invariant_mod fs mfs dmu p first b m" 
  and res: "basis_reduction_mod_add_rows_loop p mfs dmu i i = (mfs', dmu')" 
  and i: "i < m" 
shows "fs'. LLL_invariant_mod fs' mfs' dmu' p first b m 
        (i' j'. i' < i  j'  i'  μ fs i' j' = μ fs' i' j') 
        μ_small fs' i"
proof -
  {
    fix j
    assume j: "j  i" and mu_small: "μ_small_row i fs j" 
      and resj: "basis_reduction_mod_add_rows_loop p mfs dmu i j = (mfs', dmu')"
    have "fs'. LLL_invariant_mod fs' mfs' dmu' p first b m 
        (i' j'. i' < i  j'  i'  μ fs i' j' = μ fs' i' j') 
        (μ_small fs' i)"
    proof (insert fsinv mu_small resj i j, induct j arbitrary: fs mfs dmu mfs' dmu')
      case (0 fs)
      then have "(mfs', dmu') = (mfs, dmu)" by simp
      then show ?case 
        using LLL_invariant_mod_to_weak_m_to_i(3) basis_reduction_add_row_done_weak 0 by auto
    next
      case (Suc j)
      hence j: "j < i" by auto
      have in0: "i  0" using Suc(6) by simp
      define c where "c = round_num_denom (dmu $$ (i,j)) (d_of dmu (Suc j))"
      have c2: "c = round (μ fs i j)" using dmu_quot_is_round_of_μ[OF _ _ i j] c_def Suc by simp
        define mfs'' where "mfs'' = (if c=0 then mfs else mfs[ i := (map_vec (λ x. x symmod p)) (mfs ! i - c v mfs ! j)])"
        define dmu'' where "dmu'' = (if c=0 then dmu else mat m m (λ(i',j'). (if (i' = i  j'  j) 
        then (if j'=j then (dmu $$ (i,j') - c * dmu $$ (j,j')) 
              else (dmu $$ (i,j') - c * dmu $$ (j,j')) symmod (p * (d_of dmu j') * (d_of dmu (Suc j'))))
        else (dmu $$ (i',j')))))"
        have 00: "basis_reduction_mod_add_row p mfs dmu i j = (mfs'', dmu'')" 
          using mfs''_def dmu''_def unfolding basis_reduction_mod_add_row_def c_def[symmetric] by simp
        then have 01: "basis_reduction_mod_add_rows_loop p mfs'' dmu'' i j = (mfs', dmu')" 
          using basis_reduction_mod_add_rows_loop.simps(2)[of p mfs dmu i j] Suc by simp
        have fsinvi: "LLL_invariant_mod fs mfs dmu p first b i" using LLL_invariant_mod_to_weak_m_to_i[OF Suc(2)] i by simp
        then have fsinvmw: "LLL_invariant_mod_weak fs mfs dmu p first b" using LLL_invD_mod LLL_invI_modw by simp
        obtain fs'' where fs''invi: "LLL_invariant_mod fs'' mfs'' dmu'' p first b i" and
          μ_small': "(μ_small_row i fs (Suc j)  μ_small_row i fs'' j)" and
          μs: "(i' j'. i' < i  j'  i'  μ fs'' i' j' = μ fs i' j')"
          using Suc basis_reduction_mod_add_row[OF fsinvmw 00 i j] fsinvi by auto
        moreover then have μsm: "μ_small_row i fs'' j" using Suc by simp
        have fs''invwi: "LLL_invariant_weak' i fs''" using LLL_invD_mod[OF fs''invi] LLL_invI_weak by simp
        have fsinvwi: "LLL_invariant_weak' i fs" using LLL_invD_mod[OF fsinvi] LLL_invI_weak by simp
        note invw = LLL_invw'_imp_w[OF fsinvwi]
        note invw'' = LLL_invw'_imp_w[OF fs''invwi]
        have "LLL_invariant_mod fs'' mfs'' dmu'' p first b m"
        proof -
          have "( l. Suc l < m  sq_norm (gso fs'' l)  α * sq_norm (gso fs'' (Suc l)))"
          proof -
            {
              fix l
              assume l: "Suc l < m"
              have "sq_norm (gso fs'' l)  α * sq_norm (gso fs'' (Suc l))"
              proof (cases "i  Suc l")
                case True
                have deq: "k. k < m  d fs (Suc k) = d fs'' (Suc k)" 
                  using ddμ LLL_invD_mod(9)[OF fs''invi] LLL_invD_mod(9)[OF Suc(2)] dmu''_def j by simp
                {
                  fix k
                  assume k: "k < m"
                  then have "d fs (Suc k) = d fs'' (Suc k)" 
                    using ddμ LLL_invD_mod(9)[OF fs''invi] LLL_invD_mod(9)[OF Suc(2)] dmu''_def j by simp
                  have "d fs 0 = 1" "d fs'' 0 = 1" using d_def by auto
                  moreover have sqid: "sq_norm (gso fs'' k) = rat_of_int (d fs'' (Suc k)) / rat_of_int (d fs'' k)"
                    using LLL_d_Suc[OF invw''] LLL_d_pos[OF invw''] k
                    by (smt One_nat_def Suc_less_eq Suc_pred le_imp_less_Suc mult_eq_0_iff less_imp_le_nat
                        nonzero_mult_div_cancel_right of_int_0_less_iff of_int_hom.hom_zero)
                  moreover have "sq_norm (gso fs k) = rat_of_int (d fs (Suc k)) / rat_of_int (d fs k)"
                    using LLL_d_Suc[OF invw] LLL_d_pos[OF invw] k
                    by (smt One_nat_def Suc_less_eq Suc_pred le_imp_less_Suc mult_eq_0_iff less_imp_le_nat
                        nonzero_mult_div_cancel_right of_int_0_less_iff of_int_hom.hom_zero)
                  ultimately have "sq_norm (gso fs k) = sq_norm (gso fs'' k)" using k deq 
                      LLL_d_pos[OF invw] LLL_d_pos[OF invw'']
                    by (metis (no_types, lifting) Nat.lessE Suc_lessD old.nat.inject zero_less_Suc)
                }
                then show ?thesis using LLL_invD_mod(6)[OF Suc(2)] by (simp add: gram_schmidt_fs.weakly_reduced_def l)
              next
                case False
                then show ?thesis using LLL_invD_mod(6)[OF fs''invi] gram_schmidt_fs.weakly_reduced_def
                  by (metis less_or_eq_imp_le nat_neq_iff)
              qed
            }
            then show ?thesis by simp
          qed
          then have "weakly_reduced fs'' m" using gram_schmidt_fs.weakly_reduced_def by blast
          then show ?thesis using LLL_invD_mod[OF fs''invi] LLL_invI_mod by simp
        qed
        then show ?case using "01" Suc.hyps i j less_imp_le_nat μsm μs by metis
    qed
  }
  then show ?thesis using μ_small_row_refl res by auto
qed

lemma basis_reduction_mod_add_rows_outer_loop_inv:
  assumes inv: "LLL_invariant_mod fs mfs dmu p first b m"
  and "(mfs', dmu') = basis_reduction_mod_add_rows_outer_loop p mfs dmu i"
  and i: "i < m"
shows "(fs'. LLL_invariant_mod fs' mfs' dmu' p first b m  
  (j. j  i  μ_small fs' j))"
proof(insert assms, induct i arbitrary: fs mfs dmu mfs' dmu')
  case (0 fs)
  then show ?case using μ_small_def by auto
next
  case (Suc i fs mfs dmu mfs' dmu')
  obtain mfs'' dmu'' where mfs''dmu'': "(mfs'', dmu'')
    = basis_reduction_mod_add_rows_outer_loop p mfs dmu i" by (metis surj_pair)
  then obtain fs'' where fs'': "LLL_invariant_mod fs'' mfs'' dmu'' p first b m" 
    and 00: "(j. j  i  μ_small fs'' j)" using Suc by fastforce
  have "(mfs', dmu') = basis_reduction_mod_add_rows_loop p mfs'' dmu'' (Suc i) (Suc i)"
    using Suc(3,4) mfs''dmu'' by (smt basis_reduction_mod_add_rows_outer_loop.simps(2) case_prod_conv)
  then obtain fs' where 01: "LLL_invariant_mod fs' mfs' dmu' p first b m" 
    and 02: "i' j'. i' < (Suc i)  j'  i'  μ fs'' i' j' = μ fs' i' j'" and 03: "μ_small fs' (Suc i)"
    using fs'' basis_reduction_mod_add_rows_loop_inv' Suc by metis
  moreover have "j. j  (Suc i)  μ_small fs' j" using 02 00 03 μ_small_def by (simp add: le_Suc_eq)
  ultimately show ?case by blast
qed

lemma basis_reduction_mod_fs_bound:
  assumes Linv: "LLL_invariant_mod fs mfs dmu p first b k"
  and mu_small: "μ_small fs i"
  and i: "i < m"
  and nFirst: "¬ first" 
shows "fs ! i = mfs ! i"
proof -
  from LLL_invD_mod(16-17)[OF Linv] nFirst g_bnd_mode_def
  have gbnd: "g_bnd b fs" and bp: "b  (rat_of_int (p - 1))2 / (rat_of_nat m + 3)" 
    by (auto simp: mod_invariant_def bound_number_def)
  have Linvw: "LLL_invariant_weak' k fs" using LLL_invD_mod[OF Linv] LLL_invI_weak by simp
  have "fs_int_indpt n fs" using LLL_invD_mod(5)[OF Linv] Gram_Schmidt_2.fs_int_indpt.intro by simp
  then interpret fs: fs_int_indpt n fs
    using fs_int_indpt.sq_norm_fs_via_sum_mu_gso by simp
  have "gso fs 02  b" using gbnd i unfolding g_bnd_def by blast
  then have b0: "0  b" using sq_norm_vec_ge_0 dual_order.trans by auto
  have 00: "of_int fs ! i2 = (j[0..<Suc i]. (μ fs i j)2 * gso fs j2)" 
    using fs.sq_norm_fs_via_sum_mu_gso LLL_invD_mod[OF Linv] Gram_Schmidt_2.fs_int_indpt.intro i by simp 
  have 01: "j < i. (μ fs i j)2 * gso fs j2  (1 / rat_of_int 4) * gso fs j2"
  proof -
    {
      fix j
      assume j: "j < i"
      then have "¦fs.gs.μ i j¦  1 / (rat_of_int 2)" 
        using mu_small Power.linordered_idom_class.abs_square_le_1 j unfolding μ_small_def by simp
      moreover have "¦μ fs i j¦  0" by simp
      ultimately have "¦μ fs i j¦2  (1 / rat_of_int 2)2" 
        using Power.linordered_idom_class.abs_le_square_iff by fastforce
      also have " = 1 / (rat_of_int 4)" by (simp add: field_simps)
      finally have "¦μ fs i j¦2  1 / rat_of_int 4" by simp
    }
    then show ?thesis using fs.gs.μ.simps by (metis mult_right_mono power2_abs sq_norm_vec_ge_0)
  qed
  then have 0111: "j. j  set [0..<i]  (μ fs i j)2 * gso fs j2  (1 / rat_of_int 4) * gso fs j2"
    by simp
  {
    fix j
    assume j: "j < n" 
    have 011: "(μ fs i i)2 * gso fs i2 = 1 * gso fs i2"
      using fs.gs.μ.simps by simp
    have 02: "j < Suc i. gso fs j2  b"
      using gbnd i unfolding g_bnd_def by simp
    have 03: "length [0..<Suc i] = (Suc i)" by simp
    have "of_int fs ! i2 = (j[0..<i]. (μ fs i j)2 * gso fs j2) + gso fs i2"
      unfolding 00 using 011 by simp
    also have "(j[0..<i]. (μ fs i j)2 * gso fs j2)  (j[0..<i]. ((1 / rat_of_int 4) * gso fs j2))"
      using Groups_List.sum_list_mono[OF 0111] by fast
    finally have "of_int fs ! i2  (j[0..<i]. ((1 / rat_of_int 4) * gso fs j2)) + gso fs i2"
      by simp
    also have "(j[0..<i]. ((1 / rat_of_int 4) * gso fs j2))  (j[0..<i]. (1 / rat_of_int 4) * b)" 
      by (intro sum_list_mono, insert 02, auto)
    also have " gso fs i2  b" using 02 by simp
    finally have "of_int fs ! i2  (j[0..<i]. (1 / rat_of_int 4) * b) + b" by simp
    also have " = (rat_of_nat i) * ((1 / rat_of_int 4) *  b) + b" 
      using 03 sum_list_triv[of "(1 / rat_of_int 4) * b" "[0..<i]"] by simp
    also have " = (rat_of_nat i) / 4 * b + b" by simp
    also have " = ((rat_of_nat i) / 4 + 1)* b" by algebra
    also have " = (rat_of_nat i + 4) / 4 * b" by simp
    finally have "of_int fs ! i2  (rat_of_nat i + 4) / 4 * b" by simp
    also have "  (rat_of_nat (m + 3)) / 4 * b" using i b0 times_left_mono by fastforce
    finally have "of_int fs ! i2  rat_of_nat (m+3) / 4 * b" by simp
    moreover have "¦fs ! i $ j¦2  fs ! i2" using vec_le_sq_norm LLL_invD_mod(10)[OF Linv] i j by blast
    ultimately have 04: "of_int (¦fs ! i $ j¦2)  rat_of_nat (m+3) / 4 * b" using ge_trans i by linarith
    then have 05: "real_of_int (¦fs ! i $ j¦2)  real_of_rat (rat_of_nat (m+3) / 4 * b)" 
    proof -
      from j have "rat_of_int (¦fs ! i $ j¦2)  rat_of_nat (m+3) / 4 * b" using 04 by simp
      then have "real_of_int (¦fs ! i $ j¦2)  real_of_rat (rat_of_nat (m+3) / 4 * b)" 
        using j of_rat_less_eq by (metis of_rat_of_int_eq)
      then show ?thesis by simp
    qed
    define rhs where "rhs = real_of_rat (rat_of_nat (m+3) / 4 * b)"
    have rhs0: "rhs  0" using b0 i rhs_def by simp
    have fsij: "real_of_int ¦fs ! i $ j¦  0" by simp
    have "real_of_int (¦fs ! i $ j¦2) = (real_of_int ¦fs ! i $ j¦)2" by simp
    then have "(real_of_int ¦fs ! i $ j¦)2  rhs" using 05 j rhs_def by simp
    then have g1: "real_of_int ¦fs ! i $ j¦  sqrt rhs" using NthRoot.real_le_rsqrt by simp
    have pbnd: "2 * ¦fs ! i $ j¦ < p"
    proof -
      have "rat_of_nat (m+3) / 4 * b  (rat_of_nat (m +3) / 4) * (rat_of_int (p - 1))2 / (rat_of_nat m+3)"
        using bp b0 i times_left_mono SN_Orders.of_nat_ge_zero gs.m_comm times_divide_eq_right 
        by (smt gs.l_null le_divide_eq_numeral1(1))
      also have " = (rat_of_int (p - 1))2 / 4 * (rat_of_nat (m + 3) / rat_of_nat (m + 3))"
        by (metis (no_types, lifting) gs.m_comm of_nat_add of_nat_numeral times_divide_eq_left)
      finally have "rat_of_nat (m+3) / 4 * b  (rat_of_int (p - 1))2 / 4" by simp
      then have "sqrt rhs  sqrt (real_of_rat ((rat_of_int (p - 1))2 / 4))"
        unfolding rhs_def using of_rat_less_eq by fastforce
      then have two_ineq: 
        "2 * ¦fs ! i $ j¦  2 * sqrt (real_of_rat ((rat_of_int (p - 1))2 / 4))"
        using g1 by linarith
      have "2 * sqrt (real_of_rat ((rat_of_int (p - 1))2 / 4)) =
      sqrt (real_of_rat (4 * ((rat_of_int (p - 1))2 / 4)))"
        by (metis (no_types, hide_lams) real_sqrt_mult of_int_numeral of_rat_hom.hom_mult 
            of_rat_of_int_eq real_sqrt_four times_divide_eq_right)
      also have " = sqrt (real_of_rat ((rat_of_int (p - 1))2))" using i by simp
      also have "(real_of_rat ((rat_of_int (p - 1))2)) = (real_of_rat (rat_of_int (p - 1)))2"
        using Rat.of_rat_power by blast
      also have "sqrt ((real_of_rat (rat_of_int (p - 1)))2) = real_of_rat (rat_of_int (p - 1))"
        using LLL_invD_mod(15)[OF Linv] by simp
      finally have "2 * sqrt (real_of_rat ((rat_of_int (p - 1))2 / 4)) =
      real_of_rat (rat_of_int (p - 1))" by simp
      then have "2 * ¦fs ! i $ j¦  real_of_rat (rat_of_int (p - 1))"
        using two_ineq by simp
      then show ?thesis by (metis of_int_le_iff of_rat_of_int_eq zle_diff1_eq)
    qed
    have p1: "p > 1" using LLL_invD_mod[OF Linv] by blast
    interpret pm: poly_mod_2 p
      by (unfold_locales, rule p1)
    from LLL_invD_mod[OF Linv] have len: "length fs = m" and fs: "set fs  carrier_vec n" by auto
    from pm.inv_M_rev[OF pbnd, unfolded pm.M_def] have "pm.inv_M (fs ! i $ j mod p) = fs ! i $ j" .
    also have "pm.inv_M (fs ! i $ j mod p) = mfs ! i $ j" unfolding LLL_invD_mod(7)[OF Linv, symmetric] sym_mod_def
      using i j len fs by auto
    finally have "fs ! i $ j = mfs ! i $ j" ..
  }
  thus "fs ! i = mfs ! i" using LLL_invD_mod(10,13)[OF Linv i] by auto
qed

lemma basis_reduction_mod_fs_bound_first:
  assumes Linv: "LLL_invariant_mod fs mfs dmu p first b k"
  and m0: "m > 0"
  and first: "first" 
shows "fs ! 0 = mfs ! 0"
proof -
  from LLL_invD_mod(16-17)[OF Linv] first g_bnd_mode_def m0
  have gbnd: "sq_norm (gso fs 0)  b" and bp: "b  (rat_of_int (p - 1))2 / 4" 
    by (auto simp: mod_invariant_def bound_number_def)
  from LLL_invD_mod[OF Linv] have p1: "p > 1" by blast
  have Linvw: "LLL_invariant_weak' k fs" using LLL_invD_mod[OF Linv] LLL_invI_weak by simp
  have "fs_int_indpt n fs" using LLL_invD_mod(5)[OF Linv] Gram_Schmidt_2.fs_int_indpt.intro by simp
  then interpret fs: fs_int_indpt n fs
    using fs_int_indpt.sq_norm_fs_via_sum_mu_gso by simp
  from gbnd have b0: "0  b" using sq_norm_vec_ge_0 dual_order.trans by auto
  have "of_int fs ! 02 = (μ fs 0 0)2 * gso fs 02" 
    using fs.sq_norm_fs_via_sum_mu_gso LLL_invD_mod[OF Linv] Gram_Schmidt_2.fs_int_indpt.intro m0 by simp 
  also have " = gso fs 02" unfolding fs.gs.μ.simps by (simp add: gs.μ.simps)
  also have "  (rat_of_int (p - 1))2 / 4" using gbnd bp by auto
  finally have one: "of_int (sq_norm (fs ! 0))  (rat_of_int (p - 1))2 / 4" .
  {
    fix j
    assume j: "j < n" 
    have leq: "¦fs ! 0 $ j¦2  fs ! 02" using vec_le_sq_norm LLL_invD_mod(10)[OF Linv] m0 j by blast
    have "rat_of_int ((2 * ¦fs ! 0 $ j¦)^2) = rat_of_int (4 * ¦fs ! 0 $ j¦2)" by simp
    also have "  4 * of_int fs ! 02" using leq by simp
    also have "  4 * (rat_of_int (p - 1))2 / 4" using one by simp
    also have " = (rat_of_int (p - 1))2" by simp
    also have " = rat_of_int ((p - 1)2)" by simp
    finally have "(2 * ¦fs ! 0 $ j¦)^2  (p - 1)2" by linarith
    hence "2 * ¦fs ! 0 $ j¦  p - 1" using p1 
      by (smt power_mono_iff zero_less_numeral)
    hence pbnd: "2 * ¦fs ! 0 $ j¦ < p" by simp
    interpret pm: poly_mod_2 p
      by (unfold_locales, rule p1)
    from LLL_invD_mod[OF Linv] m0 have len: "length fs = m" "length mfs = m" 
      and fs: "fs ! 0  carrier_vec n" "mfs ! 0  carrier_vec n" by auto
    from pm.inv_M_rev[OF pbnd, unfolded pm.M_def] have "pm.inv_M (fs ! 0 $ j mod p) = fs ! 0 $ j" .
    also have "pm.inv_M (fs ! 0 $ j mod p) = mfs ! 0 $ j" unfolding LLL_invD_mod(7)[OF Linv, symmetric] sym_mod_def
      using m0 j len fs by auto
    finally have "mfs ! 0 $ j = fs ! 0 $ j" . 
  }
  thus "fs ! 0 = mfs ! 0" using LLL_invD_mod(10,13)[OF Linv m0] by auto
qed

lemma dmu_initial: "dmu_initial = mat m m (λ (i,j).fs_init i j)"
proof -
  interpret fs: fs_int_indpt n fs_init
    by (unfold_locales, intro lin_dep)
  show ?thesis unfolding dmu_initial_def Let_def
  proof (intro cong_mat refl refl, unfold split, goal_cases)
    case (1 i j)
    show ?case
    proof (cases "j  i")
      case False
      thus ?thesis by (auto simp: dμ_def gs.μ.simps)
    next
      case True
      hence id: "dμ_impl fs_init !! i !! j = fs.dμ i j" unfolding fs.dμ_impl
        by (subst of_fun_nth, use 1 len in force, subst of_fun_nth, insert True, auto)
      also have " =fs_init i j" unfolding fs.dμ_def dμ_def fs.d_def d_def by simp
      finally show ?thesis using True by auto
    qed
  qed
qed

lemma LLL_initial_invariant_mod: assumes res: "compute_initial_state first = (p, mfs, dmu', g_idx)" 
shows "fs b. LLL_invariant_mod fs mfs dmu' p first b 0" 
proof -
  from dmu_initial have dmu: "(i' < m. j' < m.fs_init i' j' = dmu_initial $$ (i',j'))" by auto
  obtain b g_idx where norm: "compute_max_gso_norm first dmu_initial = (b,g_idx)" by force
  note res = res[unfolded compute_initial_state_def Let_def norm split]
  from res have p: "p = compute_mod_of_max_gso_norm first b" by auto
  then have p0: "p > 0" unfolding compute_mod_of_max_gso_norm_def using log_base by simp
  then have p1: "p  1" by simp
  note res = res[folded p]
  from res[unfolded compute_initial_mfs_def]
  have mfs: "mfs = map (map_vec (λx. x symmod p)) fs_init" by auto
  from res[unfolded compute_initial_dmu_def]
  have dmu': "dmu' = mat m m (λ(i',j'). if j' < i' 
              then dmu_initial $$ (i', j') symmod (p * d_of dmu_initial j' * d_of dmu_initial (Suc j')) 
              else dmu_initial $$ (i',j'))" by auto
  have lat: "lattice_of fs_init = L" by (auto simp: L_def)
  define I where "I = {(i',j'). i' < m  j' < i'}"
  obtain fs where 
    01: "lattice_of fs = L" and
    02: "map (map_vec (λ x. x symmod p)) fs = map (map_vec (λ x. x symmod p)) fs_init" and
    03: "lin_indep fs" and
    04: "length fs = m" and
    05: "( k < m. gso fs k = gso fs_init k)" and
    06: "( k  m. d fs k = d fs_init k)" and
    07: "( i' < m.  j' < m.fs i' j' = 
      (if (i',j')  I thenfs_init i' j' symmod (p * d fs_init j' * d fs_init (Suc j')) elsefs_init i' j'))"
    using mod_finite_set[OF lin_dep len _ lat p0, of I] I_def by blast
  have inv: "LLL_invariant_weak fs_init"
    by (intro LLL_inv_wI lat len lin_dep fs_init)
  have "i'<m.fs_init i' i' = dmu_initial $$ (i', i')" unfolding dmu_initial by auto
  from compute_max_gso_norm[OF this inv, of first, unfolded norm] have gbnd: "g_bnd_mode first b fs_init" 
    and b0: "0  b" and mb0: "m = 0  b = 0" by auto
  from gbnd 05 have gbnd: "g_bnd_mode first b fs" using g_bnd_mode_cong[of fs fs_init] by auto
  have dμdmu': "i'<m. j'<m.fs i' j' = dmu' $$ (i', j')" using 07 dmu d_of_main[of fs_init dmu_initial]
    unfolding I_def dmu' by simp
  have wred: "weakly_reduced fs 0" by (simp add: gram_schmidt_fs.weakly_reduced_def)
  have fs_carr: "set fs  carrier_vec n" using 03 unfolding gs.lin_indpt_list_def by force
  have m0: "m  0" using len by auto 
  have Linv: "LLL_invariant_weak' 0 fs"
    by (intro LLL_invI_weak 03 04 01 wred fs_carr m0)
  note Linvw = LLL_invw'_imp_w[OF Linv]
  from compute_mod_of_max_gso_norm[OF b0 mb0 p]
  have p: "mod_invariant b p first" "p > 1" by auto
  from len mfs have len': "length mfs = m" by auto
  have modbnd: "i'<m. j'<i'. ¦fs i' j'¦ < p * d fs j' * d fs (Suc j')"
  proof -
    have " i' < m.  j' < i'.fs i' j' =fs i' j' symmod (p * d fs j' * d fs (Suc j'))"
      using I_def 07 06 by simp
    moreover have "j' < m. p * d fs j' * d fs (Suc j') > 0" using p(2) LLL_d_pos[OF Linvw] by simp
    ultimately show ?thesis using sym_mod_abs
      by (smt Euclidean_Division.pos_mod_bound Euclidean_Division.pos_mod_sign less_trans)
  qed
  have "LLL_invariant_mod fs mfs dmu' p first b 0" 
    using LLL_invI_mod[OF len' m0 04 01 03 wred _ modbnd dμdmu' p(2) gbnd p(1)] 02 mfs by simp
  then show ?thesis by auto
qed

subsection ‹Soundness of Storjohann's algorithm›

text ‹For all of these abstract algorithms, we actually formulate their soundness proofs by linking
  to the LLL-invariant (which implies that @{term fs} is reduced (@{term "LLL_invariant True m fs"})
  or that the first vector of @{term fs} is short (@{term "LLL_invariant_weak fs  weakly_reduced fs m"}).›

text ‹Soundness of Storjohann's algorithm›
lemma reduce_basis_mod_inv: assumes res: "reduce_basis_mod = fs"    
  shows "LLL_invariant True m fs" 
proof (cases "m = 0")
  case True
  from True have *: "fs_init = []" using len by simp
  moreover have "fs = []" using res basis_reduction_mod_add_rows_outer_loop.simps(1)
    unfolding reduce_basis_mod_def Let_def basis_reduction_mod_main.simps[of _ _ _ _ _ 0] 
      compute_initial_mfs_def compute_initial_state_def compute_initial_dmu_def 
    unfolding True * by (auto split: prod.splits)
  ultimately show ?thesis using True LLL_inv_initial_state by blast
next
  case False
  let ?first = False
  obtain p mfs0 dmu0 g_idx0 where init: "compute_initial_state ?first = (p, mfs0, dmu0, g_idx0)" by (metis prod_cases4)
  from LLL_initial_invariant_mod[OF init]
  obtain fs0 b where fs0: "LLL_invariant_mod fs0 mfs0 dmu0 p ?first b 0" by blast
  note res = res[unfolded reduce_basis_mod_def init Let_def split]
  obtain p1 mfs1 dmu1 where mfs1dmu1: "(p1, mfs1, dmu1) = basis_reduction_mod_main p ?first mfs0 dmu0 g_idx0 0 0"
    by (metis prod.exhaust)
  obtain fs1 b1 where Linv1: "LLL_invariant_mod fs1 mfs1 dmu1 p1 ?first b1 m"
    using basis_reduction_mod_main[OF fs0 mfs1dmu1[symmetric]] by auto
  obtain mfs2 dmu2 where mfs2dmu2:
    "(mfs2, dmu2) = basis_reduction_mod_add_rows_outer_loop p1 mfs1 dmu1 (m-1)" by (metis old.prod.exhaust)
  obtain fs2 where fs2: "LLL_invariant_mod fs2 mfs2 dmu2 p1 ?first b1 m" 
    and μs: "((j. j < m  μ_small fs2 j))"
    using basis_reduction_mod_add_rows_outer_loop_inv[OF _ mfs2dmu2, of fs1 ?first b1] Linv1 False by auto
  have rbd: "LLL_invariant_weak' m fs2" "j < m. μ_small fs2 j"
    using LLL_invD_mod[OF fs2] LLL_invI_weak μs by auto
  have redfs2: "reduced fs2 m" using rbd LLL_invD_weak(8) gram_schmidt_fs.reduced_def μ_small_def by blast
  have fs: "fs = mfs2" 
    using res[folded mfs1dmu1, unfolded Let_def split, folded mfs2dmu2, unfolded split] .. 
  have "i < m. fs2 ! i = fs ! i"
  proof (intro allI impI)
    fix i
    assume i: "i < m"
    then have fs2i: "LLL_invariant_mod fs2 mfs2 dmu2 p1 ?first b1 i"
      using fs2 LLL_invariant_mod_to_weak_m_to_i by simp
    have μsi: "μ_small fs2 i" using μs i by simp
    show "fs2 ! i = fs ! i" 
      using basis_reduction_mod_fs_bound(1)[OF fs2i μsi i] fs by simp
  qed
  then have "fs2 = fs"
    using LLL_invD_mod(1,3,10,13)[OF fs2] fs by (metis nth_equalityI)
  then show ?thesis using redfs2 fs rbd(1) reduce_basis_def res LLL_invD_weak 
      LLL_invariant_def by simp
qed

text ‹Soundness of Storjohann's algorithm for computing a short vector.›
lemma short_vector_mod_inv: assumes res: "short_vector_mod = v"    
  and m: "m > 0" 
  shows " fs. LLL_invariant_weak fs  weakly_reduced fs m  v = hd fs" 
proof -
  let ?first = True
  obtain p mfs0 dmu0 g_idx0 where init: "compute_initial_state ?first = (p, mfs0, dmu0, g_idx0)" by (metis prod_cases4)
  from LLL_initial_invariant_mod[OF init]
  obtain fs0 b where fs0: "LLL_invariant_mod fs0 mfs0 dmu0 p ?first b 0" by blast
  obtain p1 mfs1 dmu1 where main: "basis_reduction_mod_main p ?first mfs0 dmu0 g_idx0 0 0 = (p1, mfs1, dmu1)"
    by (metis prod.exhaust)
  obtain fs1 b1 where Linv1: "LLL_invariant_mod fs1 mfs1 dmu1 p1 ?first b1 m"
    using basis_reduction_mod_main[OF fs0 main] by auto
  have "v = hd mfs1" using res[unfolded short_vector_mod_def Let_def init split main] ..
  with basis_reduction_mod_fs_bound_first[OF Linv1 m] LLL_invD_mod(1,3)[OF Linv1] m
  have v: "v = hd fs1" by (cases fs1; cases mfs1; auto)
  from Linv1 have Linv1: "LLL_invariant_weak fs1" and red: "weakly_reduced fs1 m" 
    unfolding LLL_invariant_mod_def LLL_invariant_weak_def by auto
  show ?thesis  
    by (intro exI[of _ fs1] conjI Linv1 red v)
qed

text ‹Soundness of Storjohann's algorithm with improved swap order›
lemma reduce_basis_iso_inv: assumes res: "reduce_basis_iso = fs"
  shows "LLL_invariant True m fs" 
proof (cases "m = 0")
  case True
  then have *: "fs_init = []" using len by simp
  moreover have "fs = []" using res basis_reduction_mod_add_rows_outer_loop.simps(1)
    unfolding reduce_basis_iso_def Let_def basis_reduction_iso_main.simps[of _ _ _ _ _ 0] 
      compute_initial_mfs_def compute_initial_state_def compute_initial_dmu_def
    unfolding True * by (auto split: prod.splits)
  ultimately show ?thesis using True LLL_inv_initial_state by blast
next
  case False
  let ?first = False
  obtain p mfs0 dmu0 g_idx0 where init: "compute_initial_state ?first = (p, mfs0, dmu0, g_idx0)" by (metis prod_cases4)
  from LLL_initial_invariant_mod[OF init]
  obtain fs0 b where fs0: "LLL_invariant_mod fs0 mfs0 dmu0 p ?first b 0" by blast
  have fs0w: "LLL_invariant_mod_weak fs0 mfs0 dmu0 p ?first b" using LLL_invD_mod[OF fs0] LLL_invI_modw by simp 
  note res = res[unfolded reduce_basis_iso_def init Let_def split]
  obtain p1 mfs1 dmu1 where mfs1dmu1: "(p1, mfs1, dmu1) = basis_reduction_iso_main p ?first mfs0 dmu0 g_idx0 0"
    by (metis prod.exhaust)
  obtain fs1 b1 where Linv1: "LLL_invariant_mod fs1 mfs1 dmu1 p1 ?first b1 m"
    using basis_reduction_iso_main[OF fs0w mfs1dmu1[symmetric]] by auto
  obtain mfs2 dmu2 where mfs2dmu2:
    "(mfs2, dmu2) = basis_reduction_mod_add_rows_outer_loop p1 mfs1 dmu1 (m-1)" by (metis old.prod.exhaust)
  obtain fs2 where fs2: "LLL_invariant_mod fs2 mfs2 dmu2 p1 ?first b1 m" 
    and μs: "((j. j < m  μ_small fs2 j))"
    using basis_reduction_mod_add_rows_outer_loop_inv[OF _ mfs2dmu2, of fs1 ?first b1] Linv1 False by auto
  have rbd: "LLL_invariant_weak' m fs2" "j < m. μ_small fs2 j"
    using LLL_invD_mod[OF fs2] LLL_invI_weak μs by auto
  have redfs2: "reduced fs2 m" using rbd LLL_invD_weak(8) gram_schmidt_fs.reduced_def μ_small_def by blast
  have fs: "fs = mfs2" 
    using res[folded mfs1dmu1, unfolded Let_def split, folded mfs2dmu2, unfolded split] .. 
  have "i < m. fs2 ! i = fs ! i"
  proof (intro allI impI)
    fix i
    assume i: "i < m"
    then have fs2i: "LLL_invariant_mod fs2 mfs2 dmu2 p1 ?first b1 i"
      using fs2 LLL_invariant_mod_to_weak_m_to_i by simp
    have μsi: "μ_small fs2 i" using μs i by simp
    show "fs2 ! i = fs ! i" 
      using basis_reduction_mod_fs_bound(1)[OF fs2i μsi i] fs by simp
  qed
  then have "fs2 = fs"
    using LLL_invD_mod(1,3,10,13)[OF fs2] fs by (metis nth_equalityI)
  then show ?thesis using redfs2 fs rbd(1) reduce_basis_def res LLL_invD_weak 
      LLL_invariant_def by simp
qed

text ‹Soundness of Storjohann's algorithm to compute short vectors with improved swap order›
lemma short_vector_iso_inv: assumes res: "short_vector_iso = v"    
  and m: "m > 0" 
  shows " fs. LLL_invariant_weak fs  weakly_reduced fs m  v = hd fs" 
proof -
  let ?first = True
  obtain p mfs0 dmu0 g_idx0 where init: "compute_initial_state ?first = (p, mfs0, dmu0, g_idx0)" by (metis prod_cases4)
  from LLL_initial_invariant_mod[OF init]
  obtain fs0 b where fs0: "LLL_invariant_mod fs0 mfs0 dmu0 p ?first b 0" by blast
  have fs0w: "LLL_invariant_mod_weak fs0 mfs0 dmu0 p ?first b" using LLL_invD_mod[OF fs0] LLL_invI_modw by simp 
  obtain p1 mfs1 dmu1 where main: "basis_reduction_iso_main p ?first mfs0 dmu0 g_idx0 0 = (p1, mfs1, dmu1)"
    by (metis prod.exhaust)
  obtain fs1 b1 where Linv1: "LLL_invariant_mod fs1 mfs1 dmu1 p1 ?first b1 m"
    using basis_reduction_iso_main[OF fs0w main] by auto
  have "v = hd mfs1" using res[unfolded short_vector_iso_def Let_def init split main] ..
  with basis_reduction_mod_fs_bound_first[OF Linv1 m] LLL_invD_mod(1,3)[OF Linv1] m
  have v: "v = hd fs1" by (cases fs1; cases mfs1; auto)
  from Linv1 have Linv1: "LLL_invariant_weak fs1" and red: "weakly_reduced fs1 m" 
    unfolding LLL_invariant_mod_def LLL_invariant_weak_def by auto
  show ?thesis  
    by (intro exI[of _ fs1] conjI Linv1 red v)
qed

end

text ‹From the soundness results of these abstract versions of the algorithms, 
  one just needs to derive actual implementations that may integrate low-level
  optimizations.›

end

Theory Storjohann_Impl

section ‹Storjohann's basis reduction algorithm (concrete implementation)›

text ‹We refine the abstract algorithm into a more efficient executable one.›

theory Storjohann_Impl
  imports 
    Storjohann
begin

subsection ‹Implementation›

text ‹We basically store four components:
   The $f$-basis (as list, all values taken modulo $p$)
   The $d\mu$-matrix (as nested arrays, all values taken modulo $d_id_{i+1}p$)
   The $d$-values (as array)
   The modulo-values $d_id_{i+1}p$ (as array)
›

type_synonym state_impl = "int vec list × int iarray iarray × int iarray × int iarray" 

fun di_of :: "state_impl  int iarray" where
  "di_of (mfsi, dmui, di, mods) = di" 

context LLL
begin

fun state_impl_inv :: "_  _  _  state_impl  bool" where 
  "state_impl_inv p mfs dmu (mfsi, dmui, di, mods) = (mfsi = mfs  di = IArray.of_fun (d_of dmu) (Suc m)
      dmui = IArray.of_fun (λ i. IArray.of_fun (λ j. dmu $$ (i,j)) i) m
      mods = IArray.of_fun (λ j. p * di !! j * di !! (Suc j)) (m - 1))" 

definition state_iso_inv :: "(int × int) iarray  int iarray  bool" where
  "state_iso_inv prods di = (prods = IArray.of_fun 
           (λ i. (di !! (i+1) * di !! (i+1), di !! (i+2) * di !! i)) (m - 1))" 

definition perform_add_row :: "int  state_impl  nat  nat  int  int iarray  int  int  state_impl" where
  "perform_add_row p state i j c rowi muij dij1 = (let
     (mfsi, dmui, di, mods) = state;
       fsj = mfsi ! j;
        rowj = dmui !! j
      in 
      (case split_at i mfsi of (start, fsi # end)  start @ vec n (λ k. (fsi $ k - c * fsj $ k) symmod p) # end,
        IArray.of_fun (λ ii. if i = ii then 
         IArray.of_fun (λ jj. if jj < j then 
              (rowi !! jj - c * rowj !! jj) symmod (mods !! jj)
            else if jj = j then muij - c * dij1 
            else rowi !! jj) i
        else dmui !! ii) m, 
      di, mods))" 

definition LLL_add_row :: "int  state_impl  nat  nat  state_impl" where
  "LLL_add_row p state i j = (let
     (_, dmui, di, _) = state;
     rowi = dmui !! i;
     dij1 = di !! (Suc j);
     muij = rowi !! j;
     c = round_num_denom muij dij1
     in if c = 0 then state
      else perform_add_row p state i j c rowi muij dij1)"     


definition LLL_swap_row :: "int  state_impl  nat  state_impl" where
  "LLL_swap_row p state k = (case state of (mfsi, dmui, di, mods)  let 
        k1 = k - 1;
        kS1 = Suc k;
        muk = dmui !! k; 
        muk1 = dmui !! k1;
        mukk1 = muk !! k1;
        dk1 = di !! k1;
        dkS1 = di !! kS1;
        dk = di !! k;
        dk' = (dkS1 * dk1 + mukk1 * mukk1) div dk;
        mod1 = p * dk1 * dk';
        modk = p * dk' * dkS1
      in 
      (case split_at k1 mfsi
        of (start, fsk1 # fsk # end)  start @ fsk # fsk1 # end,
        IArray.of_fun (λ i. 
          if i < k1 then dmui !! i
          else if i > k then 
             let row_i = dmui !! i; muik = row_i !! k; muik1 = row_i !! k1 in IArray.of_fun 
                 (λ j. if j = k1 then ((mukk1 * muik1 + muik * dk1) div dk) symmod mod1 
                        else if j = k then ((dkS1 * muik1 - mukk1 * muik) div dk) symmod modk  
                        else row_i !! j) i
          else if i = k then IArray.of_fun (λ j. if j = k1 then mukk1 symmod mod1 else muk1 !! j) i
          else IArray.of_fun ((!!) muk) i 
          ) m, 
       IArray.of_fun (λ i. if i = k then dk' else di !! i) (Suc m), 
       IArray.of_fun (λ j. if j = k1 then mod1 else if j = k then modk else mods !! j) (m - 1)))"

definition perform_swap_add where "perform_swap_add p state k k1 c row_k mukk1 dk = 
(let (fs, dmu, dd, mods) = state; 
     row_k1 = dmu !! k1; 
     kS1 = Suc k;
     mukk1' = mukk1 - c * dk;
     dk1 = dd !! k1; 
     dkS1 = dd !! kS1; 
     dk' = (dkS1 * dk1 + mukk1' * mukk1') div dk; 
     mod1 = p * dk1 * dk'; 
     modk = p * dk' * dkS1
 in 
      (case split_at k1 fs of (start, fsk1 # fsk # end)  
         start @ vec n (λk. (fsk $ k - c * fsk1 $ k) symmod p) # fsk1 # end,
       IArray.of_fun
        (λi. if i < k1
              then dmu !! i
              else if k < i
                   then let row_i = dmu !! i;
                            muik1 = row_i !! k1;
                            muik = row_i !! k
                        in IArray.of_fun
                            (λj. if j = k1 then (mukk1' * muik1 + muik * dk1) div dk symmod mod1
                                 else if j = k then (dkS1 * muik1 - mukk1' * muik) div dk symmod modk 
                                 else row_i !! j)
                            i
                   else if i = k then IArray.of_fun (λj. if j = k1 then mukk1' symmod mod1 else row_k1 !! j) k 
                   else IArray.of_fun (λj. (row_k !! j - c * row_k1 !! j) symmod mods !! j) i)
        m,
       IArray.of_fun (λi. if i = k then dk' else dd !! i) (Suc m), 
       IArray.of_fun (λj. if j = k1 then mod1 else if j = k then modk else mods !! j) (m - 1)))" 


definition LLL_swap_add where
  "LLL_swap_add p state i = (let
     i1 = i - 1;
     (_, dmui, di, _) = state;
     rowi = dmui !! i;
     dii = di !! i;
     muij = rowi !! i1;
     c = round_num_denom muij dii
     in if c = 0 then LLL_swap_row p state i
      else perform_swap_add p state i i1 c rowi muij dii)"

definition LLL_max_gso_norm_di :: "bool  int iarray  rat × nat" where
  "LLL_max_gso_norm_di first di = 
      (if first then (of_int (di !! 1), 0) 
       else case max_list_rats_with_index (map (λ i. (di !! (Suc i), di !! i, i)) [0 ..< m ])
      of (num, denom, i)  (of_int num / of_int denom, i))" 

definition LLL_max_gso_quot:: "(int * int) iarray  (int * int * nat)" where
  "LLL_max_gso_quot di_prods = max_list_rats_with_index 
    (map (λi. case di_prods !! i of (l,r)  (l, r, Suc i)) [0..<(m-1)])"


definition LLL_max_gso_norm :: "bool  state_impl  rat × nat" where
  "LLL_max_gso_norm first state = (case state of (_, _, di, mods)  LLL_max_gso_norm_di first di)" 

definition perform_adjust_mod :: "int  state_impl  state_impl" where
  "perform_adjust_mod p state = (case state of (mfsi, dmui, di, _)  
          let mfsi' = map (map_vec (λx. x symmod p)) mfsi;
              mods = IArray.of_fun (λ j. p * di !! j * di !! (Suc j)) (m - 1);
              dmui' = IArray.of_fun (λ i. let row = dmui !! i in IArray.of_fun (λ j. row !! j symmod (mods !! j)) i) m
        in 
          ((mfsi', dmui', di, mods)))" 

definition mod_of_gso_norm :: "bool  rat  int" where
  "mod_of_gso_norm first mn = log_base ^ (log_ceiling log_base (max 2 (
     root_rat_ceiling 2 (mn * (rat_of_nat (if first then 4 else m + 3))) + 1)))"

definition LLL_adjust_mod :: "int  bool  state_impl  int × state_impl × nat" where
  "LLL_adjust_mod p first state = ( 
     let (b', g_idx) = LLL_max_gso_norm first state;
       p' = mod_of_gso_norm first b'
      in if p' < p then (p', perform_adjust_mod p' state, g_idx)
          else (p, state, g_idx) 
      )" 

definition LLL_adjust_swap_add where
  "LLL_adjust_swap_add p first state g_idx i = (
      let state1 = LLL_swap_add p state i
      in if i - 1 = g_idx then
      LLL_adjust_mod p first state1 else (p, state1, g_idx))" 


definition LLL_step :: "int  bool  state_impl  nat  nat  int  (int × state_impl × nat) × nat × int" where
  "LLL_step p first state g_idx i j = (if i = 0 then ((p, state, g_idx), Suc i, j)
     else let 
        i1 = i - 1; 
        iS = Suc i;
        (_, _, di, _) = state;
        (num, denom) = quotient_of α;
        d_i = di !! i;
        d_i1 = di !! i1;
        d_Si = di !! iS
       in if d_i * d_i * denom  num * d_i1 * d_Si then
          ((p, state, g_idx), iS, j) 
        else (LLL_adjust_swap_add p first state g_idx i, i1, j + 1))" 

partial_function (tailrec) LLL_main :: "int  bool  state_impl  nat  nat  int  int × state_impl"
  where
  "LLL_main p first state g_idx i (j :: int) = (
    (if i < m 
     then case LLL_step p first state g_idx i j of
         ((p', state', g_idx'), i', j')  
         LLL_main p' first state' g_idx' i' j'
       else
         (p, state)))"

partial_function (tailrec) LLL_iso_main_inner where
  "LLL_iso_main_inner p first state di_prods g_idx (j :: int) = (
      case state of (_, _, di, _) 
    (
      (let (max_gso_num, max_gso_denum, indx) = LLL_max_gso_quot di_prods;
        (num, denum) = quotient_of α in
        (if max_gso_num * denum  > num * max_gso_denum then
           case LLL_adjust_swap_add p first state g_idx indx of 
              (p', state', g_idx')  case state' of (_, _, di', _)  
              let di_prods' = IArray.of_fun (λ i. case di_prods !! i of lr  
                    if i > indx  i + 2 < indx then lr
                     else case lr of (l,r) 
                   if i + 1 = indx then let d_idx = di' !! indx in (d_idx * d_idx, r) else (l, di' !! (i + 2) * di' !! i)) (m - 1)
                in LLL_iso_main_inner p' first state' di_prods' g_idx' (j + 1)
         else
           (p, state)))))"

definition LLL_iso_main where
  "LLL_iso_main p first state g_idx j = (if m > 1 then 
     case state of (_, _, di, _) 
     let di_prods = IArray.of_fun (λ i. (di !! (i+1) * di !! (i+1), di !! (i+2) * di !! i)) (m - 1)
      in LLL_iso_main_inner p first state di_prods g_idx j else (p,state))" 


definition LLL_initial :: "bool  int × state_impl × nat" where
  "LLL_initial first = (let init = dμ_impl fs_init;
      di = IArray.of_fun (λ i. if i = 0 then 1 else let i1 = i - 1 in init !! i1 !! i1) (Suc m);
      (b,g_idx) = LLL_max_gso_norm_di first di;
      p = mod_of_gso_norm first b;
      mods = IArray.of_fun (λ j. p * di !! j * di !! (Suc j)) (m - 1);
      dmui = IArray.of_fun (λ i. let row = init !! i in IArray.of_fun (λ j. row !! j symmod (mods !! j)) i) m
      in (p, (compute_initial_mfs p, dmui, di, mods), g_idx))" 

fun LLL_add_rows_loop where
  "LLL_add_rows_loop p state i 0 = state"
| "LLL_add_rows_loop p state i (Suc j) = (
     let state' = LLL_add_row p state i j
      in LLL_add_rows_loop p state' i j)" 

primrec LLL_add_rows_outer_loop where
  "LLL_add_rows_outer_loop p state 0 = state" |
  "LLL_add_rows_outer_loop p state (Suc i) = 
    (let state' = LLL_add_rows_outer_loop p state i in
      LLL_add_rows_loop p state' (Suc i) (Suc i))"

definition 
  "LLL_reduce_basis = (if m = 0 then [] else
     let first = False;
         (p0, state0, g_idx0) = LLL_initial first;
         (p, state) = LLL_main p0 first state0 g_idx0 0 0;
         (mfs,_,_,_) = LLL_add_rows_outer_loop p state (m - 1)
      in mfs)"

definition 
  "LLL_reduce_basis_iso = (if m = 0 then [] else
     let first = False;
         (p0, state0, g_idx0) = LLL_initial first;
         (p, state) = LLL_iso_main p0 first state0 g_idx0 0;
         (mfs,_,_,_) = LLL_add_rows_outer_loop p state (m - 1)
      in mfs)"

definition 
  "LLL_short_vector = (
     let first = True;
         (p0, state0, g_idx0) = LLL_initial first;
         (p, (mfs,_,_,_)) = LLL_main p0 first state0 g_idx0 0 0
      in hd mfs)"

definition 
  "LLL_short_vector_iso = (
     let first = True;
         (p0, state0, g_idx0) = LLL_initial first;
         (p, (mfs,_,_,_)) = LLL_iso_main p0 first state0 g_idx0 0         
      in hd mfs)"

end

declare LLL.LLL_short_vector_def[code]
declare LLL.LLL_short_vector_iso_def[code]
declare LLL.LLL_reduce_basis_def[code]
declare LLL.LLL_reduce_basis_iso_def[code]
declare LLL.LLL_iso_main_def[code]
declare LLL.LLL_iso_main_inner.simps[code]
declare LLL.LLL_add_rows_outer_loop.simps[code]
declare LLL.LLL_add_rows_loop.simps[code]
declare LLL.LLL_initial_def[code]
declare LLL.LLL_main.simps[code]
declare LLL.LLL_adjust_mod_def[code]
declare LLL.LLL_max_gso_norm_def[code]
declare LLL.perform_adjust_mod_def[code]
declare LLL.LLL_max_gso_norm_di_def[code]
declare LLL.LLL_max_gso_quot_def[code]
declare LLL.LLL_step_def[code]
declare LLL.LLL_add_row_def[code]
declare LLL.perform_add_row_def[code]
declare LLL.LLL_swap_row_def[code]
declare LLL.LLL_swap_add_def[code]
declare LLL.LLL_adjust_swap_add_def[code]
declare LLL.perform_swap_add_def[code]
declare LLL.mod_of_gso_norm_def[code]
declare LLL.compute_initial_mfs_def[code]
declare LLL.log_base_def[code]


subsection ‹Towards soundness proof of implementation›

context LLL
begin
lemma perform_swap_add: assumes k: "k  0" "k < m" and fs: "length fs = m"
  shows "LLL_swap_row p (perform_add_row p (fs, dmu, di, mods) k (k - 1) c (dmu !! k) (dmu !! k !! (k - 1)) (di !! k)) k
    = perform_swap_add p (fs, dmu, di, mods) k (k - 1) c (dmu !! k) (dmu !! k !! (k - 1)) (di !! k)"
proof -
  from k[folded fs] 
  have drop: "drop k fs = fs ! k # drop (Suc k) fs"
    by (simp add: Cons_nth_drop_Suc)
  obtain v where v: "vec n (λka. (fs ! k $ ka - c * fs ! (k - 1) $ ka) symmod p) = v" by auto
  from k[folded fs] 
  have drop1: "drop (k - 1) (take k fs @ v # drop (Suc k) fs) = fs ! (k - 1) # v # drop (Suc k) fs" 
    by (simp add: Cons_nth_drop_Suc) 
      (smt Cons_nth_drop_Suc Suc_diff_Suc Suc_less_eq Suc_pred diff_Suc_less diff_self_eq_0 drop_take less_SucI take_Suc_Cons take_eq_Nil)
  from k[folded fs]
  have drop2: "drop (k - 1) fs = fs ! (k - 1) # fs ! k # drop (Suc k) fs" 
    by (metis Cons_nth_drop_Suc One_nat_def Suc_less_eq Suc_pred less_SucI neq0_conv)
  have take: "take (k - 1) (take k fs @ xs) = take (k - 1) fs" for xs using k[folded fs] by auto
  obtain rowk where rowk: "IArray.of_fun
                             (λjj. if jj < k - 1 then (dmu !! k !! jj - c * dmu !! (k - 1) !! jj) symmod mods !! jj
                else if jj = k - 1 then dmu !! k !! (k - 1) - c * di !! k else dmu !! k !! jj) k = rowk" 
    by auto
  obtain mukk1' where mukk1': "(di !! Suc k * di !! (k - 1) + rowk !! (k - 1) * rowk !! (k - 1)) div di !! k = mukk1'" 
    by auto
  have kk1: "k - 1 < k" using k by auto
  have mukk1'': "(di !! Suc k * di !! (k - 1) +
             (dmu !! k !! (k - 1) - c * di !! k) * (dmu !! k !! (k - 1) - c * di !! k)) div
            di !! k = mukk1'"
    unfolding mukk1'[symmetric] rowk[symmetric] IArray.of_fun_nth[OF kk1] by auto
  have id: "(k = k) = True" by simp
  have rowk1: "dmu !! k !! (k - 1) - c * di !! k = rowk !! (k - 1)" 
    unfolding rowk[symmetric] IArray.of_fun_nth[OF kk1] by simp
  show ?thesis 
    unfolding perform_swap_add_def split perform_add_row_def Let_def split LLL_swap_row_def split_at_def
    unfolding drop list.simps v drop1 take prod.inject drop2 rowk IArray.of_fun_nth[OF k < m] id if_True
    unfolding rowk1
  proof (intro conjI refl iarray_cong, unfold rowk1[symmetric], goal_cases)    
    case i: (1 i)
    show ?case unfolding IArray.of_fun_nth[OF i] IArray.of_fun_nth[OF k < m] id if_True mukk1' mukk1''
      rowk1[symmetric]
    proof (intro if_cong[OF refl], force, goal_cases)
      case 3
      hence i: "i = k - 1" by auto
      show ?case unfolding i by (intro iarray_cong[OF refl], unfold rowk[symmetric],
          subst IArray.of_fun_nth, insert k, auto)
    next
      case ki: 1 (* k < i *)
      hence id: "(k = i) = False" by auto 
      show ?case unfolding id if_False rowk
        by (intro iarray_cong if_cong refl)
    next
      case 2 (* k = i *)
      show ?case unfolding 2 
        by (intro iarray_cong if_cong refl, subst IArray.of_fun_nth, insert k, auto)
    qed
  qed
qed
        

lemma LLL_swap_add_eq: assumes i: "i  0" "i < m" and fs: "length fs = m" 
  shows "LLL_swap_add p (fs,dmu,di,mods) i = (LLL_swap_row p (LLL_add_row p (fs,dmu,di,mods) i (i - 1)) i)" 
proof -
  define c where "c = round_num_denom (dmu !! i !! (i - 1)) (di !! i)"
  from i have si1: "Suc (i - 1) = i" by auto
  note res1 = LLL_swap_add_def[of p "(fs,dmu,di,mods)" i, unfolded split Let_def c_def[symmetric]]
  show ?thesis
  proof (cases "c = 0")
    case True
    thus ?thesis using i unfolding res1 LLL_add_row_def split id c_def Let_def by auto
  next
    case False
    hence c: "(c = 0) = False" by simp
    have add: "LLL_add_row p (fs, dmu, di, mods) i (i - 1) = 
       perform_add_row p (fs, dmu, di, mods) i (i - 1) c (dmu !! i) (dmu !! i !! (i - 1)) (di !! i)" 
      unfolding LLL_add_row_def Let_def split si1 c_def[symmetric] c by auto 
    show ?thesis unfolding res1 c if_False add 
      by (subst perform_swap_add[OF assms]) simp
  qed
qed
end


context LLL_with_assms
begin

lemma LLL_mod_inv_to_weak: "LLL_invariant_mod fs mfs dmu p first b i  LLL_invariant_mod_weak fs mfs dmu p first b" 
  unfolding LLL_invariant_mod_def LLL_invariant_mod_weak_def by auto

declare IArray.of_fun_def[simp del]

lemma LLL_swap_row: assumes impl: "state_impl_inv p mfs dmu state" 
  and Linv: "LLL_invariant_mod_weak fs mfs dmu p first b"
  and res: "basis_reduction_mod_swap p mfs dmu k = (mfs', dmu')" 
  and res': "LLL_swap_row p state k = state'" 
  and k: "k < m" "k  0" 
shows "state_impl_inv p mfs' dmu' state'" 
proof -
  note inv = LLL_invD_modw[OF Linv]
  obtain fsi dmui di mods where state: "state = (fsi, dmui, di, mods)" by (cases state, auto)
  obtain fsi' dmui' di' mods' where state': "state' = (fsi', dmui', di', mods')" by (cases state', auto)
  from impl[unfolded state, simplified]
  have id: "fsi = mfs" 
    "di = IArray.of_fun (d_of dmu) (Suc m)" 
    "dmui = IArray.of_fun (λi. IArray.of_fun (λj. dmu $$ (i, j)) i) m" 
    "mods = IArray.of_fun (λj. p * di !! j * di !! Suc j) (m - 1)"
    by auto
  have kk1: "dmui !! k !! (k - 1) = dmu $$ (k, k - 1)" using k unfolding id 
      IArray.of_fun_nth[OF k(1)]
    by (subst IArray.of_fun_nth, auto)
  have di: "i  m  di !! i = d_of dmu i" for i
    unfolding id by (subst IArray.of_fun_nth, auto)
  have dS1: "di !! Suc k = d_of dmu (Suc k)" using di k by auto
  have d1: "di !! (k - 1) = d_of dmu (k - 1)" using di k by auto
  have dk: "di !! k = d_of dmu k" using di k by auto
  define dk' where "dk' = (d_of dmu (Suc k) * d_of dmu (k - 1) + dmu $$ (k, k - 1) * dmu $$ (k, k - 1)) div d_of dmu k" 
  define mod1 where "mod1 = p * d_of dmu (k - 1) * dk'" 
  define modk where "modk = p * dk' * d_of dmu (Suc k)" 
  define dmu'' where "dmu'' = (mat m m
      (λ(i, j).
          if j < i
          then if i = k - 1 then dmu $$ (k, j)
               else if i = k  j  k - 1 then dmu $$ (k - 1, j)
                    else if k < i  j = k then (d_of dmu (Suc k) * dmu $$ (i, k - 1) - dmu $$ (k, k - 1) * dmu $$ (i, j)) div d_of dmu k
                         else if k < i  j = k - 1 then (dmu $$ (k, k - 1) * dmu $$ (i, j) + dmu $$ (i, k) * d_of dmu (k - 1)) div d_of dmu k else dmu $$ (i, j)
          else if i = j then if i = k - 1 then (d_of dmu (Suc k) * d_of dmu (k - 1) + dmu $$ (k, k - 1) * dmu $$ (k, k - 1)) div d_of dmu k else d_of dmu (Suc i)
               else dmu $$ (i, j)))" 
  have drop: "drop (k - 1) fsi = mfs ! (k - 1) # mfs ! k # drop (Suc k) mfs" unfolding id using ‹length mfs = m k
    by (metis Cons_nth_drop_Suc One_nat_def Suc_less_eq Suc_pred less_SucI linorder_neqE_nat not_less0)
  have dk': "dk' = d_of dmu'' k" unfolding dk'_def d_of_def dmu''_def using k by auto
  have mod1: "mod1 = p * d_of dmu'' (k - 1) * d_of dmu'' k" unfolding mod1_def dk' using k
    by (auto simp: dmu''_def d_of_def)
  have modk: "modk = p * d_of dmu'' k * d_of dmu'' (Suc k)" unfolding modk_def dk' using k
    by (auto simp: dmu''_def d_of_def)
  note res = res[unfolded basis_reduction_mod_swap_def, folded dmu''_def, symmetric]
  note res' = res'[unfolded state state' split_at_def drop list.simps split LLL_swap_row_def Let_def kk1 dS1 d1 dk, 
      folded dk'_def mod1_def modk_def, symmetric]
  from res' have fsi': "fsi' = take (k - 1) mfs @ mfs ! k # mfs ! (k - 1) # drop (Suc k) mfs" unfolding id by simp
  from res' have di': "di' = IArray.of_fun (λii. if ii = k then dk' else di !! ii) (Suc m)" by simp
  from res' have dmui': "dmui' = IArray.of_fun
    (λi. if i < k - 1 then dmui !! i
         else if k < i then IArray.of_fun
                    (λj. if j = k - 1
                         then (dmu $$ (k, k - 1) * dmui !! i !! (k - 1) + dmui !! i !! k * d_of dmu (k - 1)) 
                                 div d_of dmu k symmod mod1
                         else if j = k
                              then (d_of dmu (Suc k) * dmui !! i !! (k - 1) - dmu $$ (k, k - 1) * dmui !! i !! k) 
                                 div d_of dmu k symmod modk                                   
                              else dmui !! i !! j)
                    i
              else if i = k then IArray.of_fun (λj. if j = k - 1 then dmu $$ (k, k - 1) symmod mod1 
        else dmui !! (k - 1) !! j) i else IArray.of_fun ((!!) (dmui !! k)) i)
    m" by auto
  from res' have mods': "mods' = IArray.of_fun (λjj. if jj = k - 1 then mod1 else if jj = k then modk else mods !! jj) (m - 1)"
    by auto
  from res have dmu': "dmu' = basis_reduction_mod_swap_dmu_mod p dmu'' k" by auto
  show ?thesis unfolding state' state_impl_inv.simps
  proof (intro conjI)
    from res have mfs': "mfs' = mfs[k := mfs ! (k - 1), k - 1 := mfs ! k]" by simp
    show "fsi' = mfs'" unfolding fsi' mfs' using ‹length mfs = m k 
    proof (intro nth_equalityI, force, goal_cases)
      case (1 j)
      have choice: "j = k - 1  j = k  j < k - 1  j > k" by linarith
      have "min (length mfs) (k - 1) = k - 1" using 1 by auto
      with 1 choice show ?case by (auto simp: nth_append)
    qed
    show "di' = IArray.of_fun (d_of dmu') (Suc m)" unfolding di' 
    proof (intro iarray_cong refl, goal_cases)
      case i: (1 i)
      hence "d_of dmu' i = d_of dmu'' i" unfolding dmu' basis_reduction_mod_swap_dmu_mod_def d_of_def
        by (intro if_cong, auto)
      also have " = ((if i = k then dk' else di !! i))" 
      proof (cases "i = k")
        case False
        hence "d_of dmu'' i = d_of dmu i" unfolding dmu''_def d_of_def using i k
          by (intro if_cong refl, auto)
        thus ?thesis using False i k unfolding id by (metis iarray_of_fun_sub)
      next
        case True
        thus ?thesis using dk' by auto
      qed
      finally show ?case by simp
    qed
    have dkS1: "d_of dmu (Suc k) = d_of dmu'' (Suc k)" 
      unfolding dmu''_def d_of_def using k by auto
    have dk1: "d_of dmu (k - 1) = d_of dmu'' (k - 1)" 
      unfolding dmu''_def d_of_def using k by auto
    show "dmui' = IArray.of_fun (λi. IArray.of_fun (λj. dmu' $$ (i, j)) i) m" 
      unfolding dmui'
    proof (intro iarray_cong refl, goal_cases)
      case i: (1 i)
      consider (1) "i < k - 1" | (2) "i = k - 1" | (3) "i = k" | (4) "i > k" by linarith
      thus ?case
      proof (cases)
        case 1
        hence *: "(i < k - 1) = True" by simp
        show ?thesis unfolding * if_True id IArray.of_fun_nth[OF i] using i k 1
          by (intro iarray_cong refl, auto simp: dmu' basis_reduction_mod_swap_dmu_mod_def, auto simp: dmu''_def)
      next
        case 2
        hence *: "(i < k - 1) = False" "(k < i) = False" "(i = k) = False" using k by auto
        show ?thesis unfolding * if_False id using i k 2 unfolding IArray.of_fun_nth[OF k(1)]
          by (intro iarray_cong refl, subst IArray.of_fun_nth, auto simp: dmu' basis_reduction_mod_swap_dmu_mod_def dmu''_def)
      next
        case 3
        hence *: "(i < k - 1) = False" "(k < i) = False" "(i = k) = True" using k by auto
        show ?thesis unfolding * if_False if_True id IArray.of_fun_nth[OF k(1)]
        proof (intro iarray_cong refl, goal_cases)
          case j: (1 j)
          show ?case
          proof (cases "j = k - 1")
            case False
            hence *: "(j = k - 1) = False" by auto
            show ?thesis unfolding * if_False using False j k i 3
              by (subst IArray.of_fun_nth, force, subst IArray.of_fun_nth, force, auto simp: dmu' basis_reduction_mod_swap_dmu_mod_def dmu''_def)
          next
            case True
            hence *: "(j = k - 1) = True" by auto
            show ?thesis unfolding * if_True unfolding True 3 using k
              by (auto simp: basis_reduction_mod_swap_dmu_mod_def dmu' dk' mod1 dmu''_def)
          qed
        qed
      next
        case 4
        hence *: "(i < k - 1) = False" "(k < i) = True" using k by auto
        show ?thesis unfolding * if_False if_True id IArray.of_fun_nth[OF k(1)] IArray.of_fun_nth[OF i < m]
        proof (intro iarray_cong refl, goal_cases)
          case j: (1 j)
          from 4 have k1: "k - 1 < i" by auto
          show ?case unfolding IArray.of_fun_nth[OF j] IArray.of_fun_nth[OF 4] IArray.of_fun_nth[OF k1]
            unfolding mod1 modk dmu' basis_reduction_mod_swap_dmu_mod_def using i j 4 k
            by (auto intro!: arg_cong[of _ _ "λ x. x symmod _"], auto simp: dmu''_def)
        qed
      qed
    qed
    show "mods' = IArray.of_fun (λj. p * di' !! j * di' !! Suc j) (m - 1)" 
      unfolding mods' di' dk' mod1 modk
    proof (intro iarray_cong refl, goal_cases)
      case (1 j)
      hence j: "j < Suc m" "Suc j < Suc m" by auto
      show ?case unfolding  
        IArray.of_fun_nth[OF 1]
        IArray.of_fun_nth[OF j(1)]
        IArray.of_fun_nth[OF j(2)] id(4) using k di dk1 dkS1
        by auto
    qed
  qed
qed


lemma LLL_add_row: assumes impl: "state_impl_inv p mfs dmu state" 
  and Linv: "LLL_invariant_mod_weak fs mfs dmu p first b" 
  and res: "basis_reduction_mod_add_row p mfs dmu i j = (mfs', dmu')" 
  and res': "LLL_add_row p state i j = state'" 
  and i: "i < m"
  and j: "j < i"
shows "state_impl_inv p mfs' dmu' state'"
proof - 
  note inv = LLL_invD_modw[OF Linv]
  obtain fsi dmui di mods where state: "state = (fsi, dmui, di, mods)" by (cases state, auto)
  obtain fsi' dmui' di' mods' where state': "state' = (fsi', dmui', di', mods')" by (cases state', auto)
  from impl[unfolded state, simplified]
  have id: "fsi = mfs" 
    "di = IArray.of_fun (d_of dmu) (Suc m)" 
    "dmui = IArray.of_fun (λi. IArray.of_fun (λj. dmu $$ (i, j)) i) m"
    "mods = IArray.of_fun (λj. p * di !! j * di !! Suc j) (m - 1)" 
    by auto
  let ?c = "round_num_denom (dmu $$ (i, j)) (d_of dmu (Suc j))" 
  let ?c' = "round_num_denom (dmui !! i !! j) (di !! Suc j)" 
  obtain c where c: "?c = c" by auto
  have c': "?c' = c" unfolding id c[symmetric] using i j
    by (subst (1 2) IArray.of_fun_nth, (force+)[2],
      subst IArray.of_fun_nth, force+)
  have drop: "drop i fsi = mfs ! i # drop (Suc i) mfs" unfolding id using ‹length mfs = m i
    by (metis Cons_nth_drop_Suc)
  note res = res[unfolded basis_reduction_mod_add_row_def Let_def c, symmetric]
  note res' = res'[unfolded state state' split LLL_add_row_def Let_def c', symmetric]
  show ?thesis 
  proof (cases "c = 0")
    case True
    from res[unfolded True] res'[unfolded True] show ?thesis unfolding state' using id by auto
  next
    case False
    hence False: "(c = 0) = False" by simp
    note res = res[unfolded Let_def False if_False]
    from res have mfs': "mfs' = mfs[i := map_vec (λx. x symmod p) (mfs ! i - c v mfs ! j)]" by auto
    from res have dmu': "dmu' = mat m m (λ(i', j').
        if i' = i  j'  j
        then if j' = j then dmu $$ (i, j') - c * dmu $$ (j, j')
             else (dmu $$ (i, j') - c * dmu $$ (j, j')) symmod (p * d_of dmu j' * d_of dmu (Suc j'))
        else dmu $$ (i', j'))" by auto
    note res' = res'[unfolded Let_def False if_False perform_add_row_def drop list.simps split_at_def split]
    from res' have fsi': "fsi' = take i fsi @ vec n (λk. (mfs ! i $ k - c * mfs ! j $ k) symmod p) # drop (Suc i) mfs" 
      by (auto simp: id)
    from res' have di': "di' = di" and mods': "mods' = mods" by auto
    from res' have dmui': "dmui' = IArray.of_fun (λii. if i = ii
          then IArray.of_fun
                (λjj. if jj < j then (dmui !! i !! jj - c * dmui !! j !! jj) symmod (mods !! jj)
                      else if jj = j then dmui !! i !! j - c * di !! (Suc j) else dmui !! i !! jj)
                i
          else dmui !! ii) m" by auto
    show ?thesis unfolding state' state_impl_inv.simps
    proof (intro conjI)
      from inv(11) i j have vec: "mfs ! i  carrier_vec n" "mfs ! j  carrier_vec n" by auto
      hence id': "map_vec (λx. x symmod p) (mfs ! i - c v mfs ! j) = vec n (λk. (mfs ! i $ k - c * mfs ! j $ k) symmod p)" 
        by (intro eq_vecI, auto)
      show "mods' = IArray.of_fun (λj. p * di' !! j * di' !! Suc j) (m - 1)" using id unfolding mods' di' by auto
      show "fsi' = mfs'" unfolding fsi' mfs' id unfolding id' using ‹length mfs = m i
        by (simp add: upd_conv_take_nth_drop)
      show "di' = IArray.of_fun (d_of dmu') (Suc m)" 
        unfolding dmu' di' id d_of_def
        by (intro iarray_cong if_cong refl, insert i j, auto)
      show "dmui' = IArray.of_fun (λi. IArray.of_fun (λj. dmu' $$ (i, j)) i) m" 
        unfolding dmui'
      proof (intro iarray_cong refl)
        fix ii
        assume ii: "ii < m" 
        show "(if i = ii
           then IArray.of_fun
                 (λjj. if jj < j then (dmui !! i !! jj - c * dmui !! j !! jj) symmod (mods !! jj)
                       else if jj = j then dmui !! i !! j - c * di !! (Suc j) else dmui !! i !! jj)
                 i
           else dmui !! ii) =
          IArray.of_fun (λj. dmu' $$ (ii, j)) ii" 
        proof (cases "i = ii")
          case False
          hence *: "(i = ii) = False" by auto
          show ?thesis unfolding * if_False id dmu' using False i j ii
            unfolding IArray.of_fun_nth[OF ii]
            by (intro iarray_cong refl, auto)
        next
          case True
          hence *: "(i = ii) = True" by auto         
          from i j have "j < m" by simp
          show ?thesis unfolding * if_True dmu' id IArray.of_fun_nth[OF i] IArray.of_fun_nth[OF j < m]
            unfolding True[symmetric]
          proof (intro iarray_cong refl, goal_cases)
            case jj: (1 jj)
            consider (1) "jj < j" | (2) "jj = j" | (3) "jj > j" by linarith
            thus ?case 
            proof cases
              case 1
              thus ?thesis using jj i j unfolding id(4)
                by (subst (1 2 3 4 5 6) IArray.of_fun_nth, auto)
            next
              case 2
              thus ?thesis using jj i j
                by (subst (5 6) IArray.of_fun_nth, auto simp: d_of_def)
            next
              case 3
              thus ?thesis using jj i j
                by (subst (7) IArray.of_fun_nth, auto simp: d_of_def)
            qed
          qed
        qed
      qed
    qed
  qed
qed


lemma LLL_max_gso_norm_di: assumes di: "di = IArray.of_fun (d_of dmu) (Suc m)"
  and m: "m  0" 
shows "LLL_max_gso_norm_di first di = compute_max_gso_norm first dmu"
proof -
  have di: "j  m  di !! j = d_of dmu j" for j unfolding di
    by (subst IArray.of_fun_nth, auto)
  have id: "(m = 0) = False" using m by auto
  show ?thesis
  proof (cases first)
    case False
    hence id': "first = False" by auto
    show ?thesis unfolding LLL_max_gso_norm_di_def compute_max_gso_norm_def id id' if_False
      by (intro if_cong refl arg_cong[of _ _ "λ xs. case max_list_rats_with_index xs of (num, denom, i)  (rat_of_int num / rat_of_int denom, i)"], 
          unfold map_eq_conv, intro ballI, subst (1 2) di, auto)
  next
    case True
    hence id': "first = True" by auto
    show ?thesis unfolding LLL_max_gso_norm_di_def compute_max_gso_norm_def id id' if_False if_True
      using m di[of 1]
      by (simp add: d_of_def)
  qed
qed

lemma LLL_max_gso_quot: assumes di: "di = IArray.of_fun (d_of dmu) (Suc m)"
  and prods: "state_iso_inv di_prods di" 
shows "LLL_max_gso_quot di_prods = compute_max_gso_quot dmu"
proof -
  have di: "j  m  di !! j = d_of dmu j" for j unfolding di
    by (subst IArray.of_fun_nth, auto)
  show ?thesis unfolding LLL_max_gso_quot_def compute_max_gso_quot_def prods[unfolded state_iso_inv_def]
    by (intro if_cong refl arg_cong[of _ _ max_list_rats_with_index], unfold map_eq_conv Let_def, intro ballI,
     subst IArray.of_fun_nth, force, unfold split,
     subst (1 2 3 4) di, auto)
qed

lemma LLL_max_gso_norm: assumes impl: "state_impl_inv p mfs dmu state" 
  and m: "m  0" 
shows "LLL_max_gso_norm first state = compute_max_gso_norm first dmu"
proof -
  obtain mfsi dmui di mods where state: "state = (mfsi, dmui, di,mods)" 
    by (metis prod_cases3)
  from impl[unfolded state state_impl_inv.simps]
  have di: "di = IArray.of_fun (d_of dmu) (Suc m)" by auto
  show ?thesis using LLL_max_gso_norm_di[OF di m] unfolding LLL_max_gso_norm_def state split .
qed

lemma mod_of_gso_norm: "m  0  mod_of_gso_norm first mn =
  compute_mod_of_max_gso_norm first mn" 
  unfolding mod_of_gso_norm_def compute_mod_of_max_gso_norm_def bound_number_def
  by auto

lemma LLL_adjust_mod: assumes impl: "state_impl_inv p mfs dmu state" 
  and res: "basis_reduction_adjust_mod p first mfs dmu = (p', mfs', dmu', g_idx)" 
  and res': "LLL_adjust_mod p first state = (p'', state', g_idx')" 
  and m: "m  0" 
shows "state_impl_inv p' mfs' dmu' state'  p'' = p'  g_idx' = g_idx"
proof -
  from LLL_max_gso_norm[OF impl m] 
  have id: "LLL_max_gso_norm first state = compute_max_gso_norm first dmu" by auto
  obtain b gi where norm: "compute_max_gso_norm first dmu = (b, gi)" by force
  obtain P where P: "compute_mod_of_max_gso_norm first b = P" by auto
  note res = res[unfolded basis_reduction_adjust_mod.simps Let_def P norm split]
  note res' = res'[unfolded LLL_adjust_mod_def id Let_def P norm split mod_of_gso_norm[OF m]]
  show ?thesis
  proof (cases "P < p")
    case False
    thus ?thesis using res res' impl by (auto split: if_splits)
  next
    case True
    hence id: "(P < p) = True" by auto
    obtain fsi dmui di mods where state: "state = (fsi, dmui, di, mods)" by (metis prod_cases3)
    from impl[unfolded state state_impl_inv.simps]
    have impl: "fsi = mfs" "di = IArray.of_fun (d_of dmu) (Suc m)" "dmui = IArray.of_fun (λi. IArray.of_fun (λj. dmu $$ (i, j)) i) m" by auto
    note res = res[unfolded id if_True]
    from res have mfs': "mfs' = map (map_vec (λx. x symmod P)) mfs" 
       and p': "p' = P" 
       and dmu': "dmu' = mat m m (λ(i, j). if j < i then dmu $$ (i, j) symmod (P * vec (Suc m) (d_of dmu) $ j * vec (Suc m) (d_of dmu) $ Suc j) else dmu $$ (i, j))" 
       and gidx: "g_idx = gi" 
      by auto
    let ?mods = "IArray.of_fun (λj. P * di !! j * di !! Suc j) (m - 1)" 
    let ?dmu = "IArray.of_fun (λi. IArray.of_fun (λj. dmui !! i !! j symmod ?mods !! j) i) m" 
    note res' = res'[unfolded id if_True state split impl(1) perform_adjust_mod_def Let_def]
    from res' have p'': "p'' = P" and state': "state' = (map (map_vec (λx. x symmod P)) mfs, ?dmu, di, ?mods)" 
       and gidx': "g_idx' = gi" by auto
    show ?thesis unfolding state' state_impl_inv.simps mfs' p'' p' gidx gidx'
    proof (intro conjI refl)
      show "di = IArray.of_fun (d_of dmu') (Suc m)" unfolding impl
        by (intro iarray_cong refl, auto simp: dmu' d_of_def)
      show "?dmu = IArray.of_fun (λi. IArray.of_fun (λj. dmu' $$ (i, j)) i) m" 
      proof (intro iarray_cong refl, goal_cases)
        case (1 i j)
        hence "j < m" "Suc j < Suc m" "j < Suc m" "j < m - 1" by auto
        show ?case unfolding dmu' impl IArray.of_fun_nth[OF i < m] IArray.of_fun_nth[OF j < i]
            IArray.of_fun_nth[OF j < m] IArray.of_fun_nth[OF ‹Suc j < Suc m]
            IArray.of_fun_nth[OF j < Suc m] IArray.of_fun_nth[OF j < m - 1] using 1 by auto
      qed
    qed
  qed
qed

lemma LLL_adjust_swap_add: assumes impl: "state_impl_inv p mfs dmu state" 
  and Linv: "LLL_invariant_mod_weak fs mfs dmu p first b"
  and res: "basis_reduction_adjust_swap_add_step p first mfs dmu g_idx k = (p', mfs', dmu', g_idx')" 
  and res': "LLL_adjust_swap_add p first state g_idx k = (p'',state', G_idx')" 
  and k: "k < m" and k0: "k  0" 
shows "state_impl_inv p' mfs' dmu' state'" "p'' = p'" "G_idx' = g_idx'" 
  "i  m  i  k  di_of state' !! i = di_of state !! i" 
proof (atomize(full), goal_cases)
  case 1
  from k have m: "m  0" by auto
  obtain mfsi dmui di mods where state: "state = (mfsi, dmui, di, mods)" 
    by (metis prod_cases3)
  obtain state'' where add': "LLL_add_row p state k (k - 1) = state''" by blast
  obtain mfs'' dmu'' where add: "basis_reduction_mod_add_row p mfs dmu k (k - 1) = (mfs'', dmu'')" by force
  obtain mfs3 dmu3 where swap: "basis_reduction_mod_swap p mfs'' dmu'' k = (mfs3, dmu3)" by force
  obtain state3 where swap': "LLL_swap_row p state'' k = state3" by blast
  obtain mfsi2 dmui2 di2 mods2 where state2: "state'' = (mfsi2, dmui2, di2, mods2)" by (cases state'', auto)
  obtain mfsi3 dmui3 di3 mods3 where state3: "state3 = (mfsi3, dmui3, di3, mods3)" by (cases state3, auto)
  have "length mfsi = m" using impl[unfolded state state_impl_inv.simps] LLL_invD_modw[OF Linv] by auto
  note res' = res'[unfolded state LLL_adjust_swap_add_def LLL_swap_add_eq[OF k0 k this], folded state, unfolded add' swap' Let_def]
  note res = res[unfolded basis_reduction_adjust_swap_add_step_def Let_def add split swap]
  from LLL_add_row[OF impl Linv add add' k] k0
  have impl': "state_impl_inv p mfs'' dmu'' state''" by auto
  from basis_reduction_mod_add_row[OF Linv add k _ k0] k0
  obtain fs'' where Linv': "LLL_invariant_mod_weak fs'' mfs'' dmu'' p first b" by auto
  from LLL_swap_row[OF impl' Linv' swap swap' k k0] 
  have impl3: "state_impl_inv p mfs3 dmu3 state3" .
  have di2: "di2 = di" using add'[unfolded state LLL_add_row_def Let_def split perform_add_row_def state2]
    by (auto split: if_splits)
  have di3: "di3 = IArray.of_fun (λi. if i = k then (di2 !! Suc k * di2 !! (k - 1) + dmui2 !! k !! (k - 1) * dmui2 !! k !! (k - 1)) div di2 !! k else di2 !! i) (Suc m)" 
    using swap'[unfolded state2 state3] 
    unfolding LLL_swap_row_def Let_def by simp 
  have di3: "i  m  i  k  di3 !! i = di !! i"
    unfolding di2[symmetric] di3 
    by (subst IArray.of_fun_nth, auto)
  show ?case
  proof (cases "k - 1 = g_idx")
    case True
    hence id: "(k - 1 = g_idx) = True" by simp
    note res = res[unfolded id if_True]
    note res' = res'[unfolded id if_True]
    obtain mfsi4 dmui4 di4 mods4 where state': "state' = (mfsi4, dmui4, di4, mods4)" by (cases state', auto)
    from res'[unfolded state3 state' LLL_adjust_mod_def Let_def perform_adjust_mod_def] have di4: "di4 = di3" 
      by (auto split: if_splits prod.splits)
    from LLL_adjust_mod[OF impl3 res res' m] di3 state state' di4 res'
    show ?thesis by auto
  next
    case False
    hence id: "(k - 1 = g_idx) = False" by simp
    note res = res[unfolded id if_False]
    note res' = res'[unfolded id if_False]
    from impl3 res res' di3 state state3 show ?thesis by auto
  qed
qed
  


lemma LLL_step: assumes impl: "state_impl_inv p mfs dmu state" 
  and Linv: "LLL_invariant_mod_weak fs mfs dmu p first b"
  and res: "basis_reduction_mod_step p first mfs dmu g_idx k j = (p', mfs', dmu', g_idx', k', j')" 
  and res': "LLL_step p first state g_idx k j = ((p'',state', g_idx''), k'', j'')" 
  and k: "k < m" 
shows "state_impl_inv p' mfs' dmu' state'  k'' = k'  p'' = p'  j'' = j'  g_idx'' = g_idx'"
proof (cases "k = 0")
  case True
  thus ?thesis using res res' impl unfolding LLL_step_def basis_reduction_mod_step_def by auto
next
  case k0: False
  hence id: "(k = 0) = False" by simp
  note res = res[unfolded basis_reduction_mod_step_def id if_False]
  obtain num denom where alph: "quotient_of α = (num,denom)" by force
  obtain mfsi dmui di mods where state: "state = (mfsi, dmui, di, mods)" 
    by (metis prod_cases3)
  note res' = res'[unfolded LLL_step_def id if_False Let_def state split alph, folded state]
  from k0 have kk1: "k - 1 < k" by auto
  note res = res[unfolded Let_def alph split]
  obtain state'' where addi: "LLL_swap_add p state k = state''" by auto
  from impl[unfolded state state_impl_inv.simps] 
  have di: "di = IArray.of_fun (d_of dmu) (Suc m)" by auto
  have id: "di !! k = d_of dmu k" 
    "di !! (Suc k) = d_of dmu (Suc k)" 
    "di !! (k - 1) = d_of dmu (k - 1)" 
    unfolding di using k
    by (subst IArray.of_fun_nth, force, force)+
  have "length mfsi = m" using impl[unfolded state state_impl_inv.simps] LLL_invD_modw[OF Linv] by auto
  note res' = res'[unfolded id]
  let ?cond = "d_of dmu k * d_of dmu k * denom  num * d_of dmu (k - 1) * d_of dmu (Suc k)" 
  show ?thesis
  proof (cases ?cond)
    case True
    from True res res' state show ?thesis using impl by auto
  next
    case False
    hence cond: "?cond = False" by simp
    note res = res[unfolded cond if_False]
    note res' = res'[unfolded cond if_False]
    let ?step = "basis_reduction_adjust_swap_add_step p first mfs dmu g_idx k" 
    let ?step' = "LLL_adjust_swap_add p first state g_idx k" 
    from res have step: "?step = (p', mfs', dmu', g_idx')" by (cases ?step, auto)
    note res = res[unfolded step split]
    from res' have step': "?step' = (p'',state', g_idx'')" by auto
    note res' = res'[unfolded step']
    from LLL_adjust_swap_add[OF impl Linv step step' k k0] 
    show ?thesis using res res' by auto
  qed
qed


lemma LLL_main: assumes impl: "state_impl_inv p mfs dmu state" 
  and Linv: "LLL_invariant_mod fs mfs dmu p first b i"
  and res: "basis_reduction_mod_main p first mfs dmu g_idx i k = (p', mfs', dmu')" 
  and res': "LLL_main p first state g_idx i k = (pi', state')" 
shows "state_impl_inv p' mfs' dmu' state'  pi' = p'"
  using assms
proof (induct "LLL_measure i fs" arbitrary: mfs dmu state fs p b k i g_idx rule: less_induct)
  case (less fs i mfs dmu state p b k g_idx)
  note impl = less(2)
  note Linv = less(3)
  note res = less(4)
  note res' = less(5)
  note IH = less(1)
  note res = res[unfolded basis_reduction_mod_main.simps[of _ _ _ _ _ _ k]]
  note res' = res'[unfolded LLL_main.simps[of _ _ _ _ _ k]]
  note Linvw = LLL_mod_inv_to_weak[OF Linv]
  show ?case
  proof (cases "i < m")
    case False
    thus ?thesis using res res' impl by auto
  next 
    case i: True
    hence id: "(i < m) = True" by simp
    obtain P'' state'' I'' K'' G_idx'' where step': "LLL_step p first state g_idx i k = ((P'', state'', G_idx''), I'', K'')" 
      by (metis prod_cases3)
    obtain p'' mfs'' dmu'' i'' k'' g_idx'' where step: "basis_reduction_mod_step p first mfs dmu g_idx i k = (p'', mfs'', dmu'', g_idx'', i'', k'')" 
      by (metis prod_cases3)
    from LLL_step[OF impl Linvw step step' i]
    have impl'': "state_impl_inv p'' mfs'' dmu'' state''" and ID: "I'' = i''" "K'' = k''" "P'' = p''" "G_idx'' = g_idx''" by auto
    from basis_reduction_mod_step[OF Linv step i] obtain
       fs'' b'' where 
       Linv'': "LLL_invariant_mod fs'' mfs'' dmu'' p'' first b'' i''" and 
       decr: "LLL_measure i'' fs'' < LLL_measure i fs" by auto
    note res = res[unfolded id if_True step split]
    note res' = res'[unfolded id if_True step' split ID]
    show ?thesis
      by (rule IH[OF decr impl'' Linv'' res res'])
  qed
qed

lemma LLL_iso_main_inner: assumes impl: "state_impl_inv p mfs dmu state" 
  and di_prods: "state_iso_inv di_prods (di_of state)" 
  and Linv: "LLL_invariant_mod_weak fs mfs dmu p first b"
  and res: "basis_reduction_iso_main p first mfs dmu g_idx k = (p', mfs', dmu')" 
  and res': "LLL_iso_main_inner p first state di_prods g_idx k = (pi', state')" 
  and m: "m > 1" 
shows "state_impl_inv p' mfs' dmu' state'  pi' = p'"
  using assms(1-5)
proof (induct "LLL_measure (m - 1) fs" arbitrary: mfs dmu state fs p b k di_prods g_idx rule: less_induct)
  case (less fs mfs dmu state p b k di_prods g_idx)
  note impl = less(2)
  note di_prods  = less(3)
  note Linv = less(4)
  note res = less(5)
  note res' = less(6)
  note IH = less(1)
  obtain mfsi dmui di mods where state: "state = (mfsi, dmui, di, mods)" 
    by (metis prod_cases4)
  from di_prods state have di_prods: "state_iso_inv di_prods di" by auto
  obtain num denom idx where quot': "LLL_max_gso_quot di_prods = (num, denom, idx)" 
    by (metis prod_cases3)
  note inv = LLL_invD_modw[OF Linv]
  obtain na da where alph: "quotient_of α = (na,da)" by force
  from impl[unfolded state] have di: "di = IArray.of_fun (d_of dmu) (Suc m)" by auto
  from LLL_max_gso_quot[OF di di_prods] have quot: "compute_max_gso_quot dmu = LLL_max_gso_quot di_prods" ..
  obtain cmp where cmp: "(na * denom < num * da) = cmp" by force
  have "(m > 1) = True" using m by auto
  note res = res[unfolded basis_reduction_iso_main.simps[of _ _ _ _ _ k] this if_True Let_def quot quot' split alph cmp]
  note res' = res'[unfolded LLL_iso_main_inner.simps[of _ _ _ _ _ k] state split Let_def quot' alph cmp, folded state]
  note cmp = compute_max_gso_quot_alpha[OF Linv quot[unfolded quot'] alph cmp m]
  show ?case
  proof (cases cmp)
    case False
    thus ?thesis using res res' impl by auto
  next 
    case True
    hence id: "cmp = True" by simp 
    note cmp = cmp(1)[OF True]
    obtain state'' P'' G_idx'' where step': "LLL_adjust_swap_add p first state g_idx idx = (P'',state'', G_idx'')" 
      by (metis prod.exhaust)
    obtain mfs'' dmu'' p'' g_idx'' where step: "basis_reduction_adjust_swap_add_step p first mfs dmu g_idx idx = (p'', mfs'', dmu'', g_idx'')" 
      by (metis prod_cases3)
    obtain mfsi2 dmui2 di2 mods2 where state2: "state'' = (mfsi2, dmui2, di2, mods2)" by (cases state'', auto)
    note res = res[unfolded id if_True step split]
    note res' = res'[unfolded id if_True step' state2 split, folded state2]
    from cmp have idx0: "idx  0" and idx: "idx < m" and ineq: "¬ d_of dmu idx * d_of dmu idx * da  na * d_of dmu (idx - 1) * d_of dmu (Suc idx)" 
      by auto
    from basis_reduction_adjust_swap_add_step[OF Linv step alph ineq idx idx0]
    obtain fs'' b'' where Linv'': "LLL_invariant_mod_weak fs'' mfs'' dmu'' p'' first b''" and
       meas: "LLL_measure (m - 1) fs'' < LLL_measure (m - 1) fs" by auto
    from LLL_adjust_swap_add[OF impl Linv step step' idx idx0]
    have impl'': "state_impl_inv p'' mfs'' dmu'' state''" and P'': "P'' = p''" "G_idx'' = g_idx''" 
      and di_prod_upd: " i. i  m  i  idx  di2 !! i = di !! i" 
      using state state2 by auto
    have di_prods: "state_iso_inv (IArray.of_fun
       (λi. if idx < i  i + 2 < idx then di_prods !! i
            else case di_prods !! i of (l, r)  if i + 1 = idx then (di2 !! idx * di2 !! idx, r) else (l, di2 !! (i + 2) * di2 !! i))
       (m - 1)) di2" unfolding state_iso_inv_def
      by (intro iarray_cong', insert di_prod_upd, unfold di_prods[unfolded state_iso_inv_def],
        subst (1 2) IArray.of_fun_nth, auto)
    show ?thesis 
      by (rule IH[OF meas impl'' _ Linv'' res res'[unfolded step' P'']], insert di_prods state2, auto)
  qed
qed

lemma LLL_iso_main: assumes impl: "state_impl_inv p mfs dmu state" 
  and Linv: "LLL_invariant_mod_weak fs mfs dmu p first b"
  and res: "basis_reduction_iso_main p first mfs dmu g_idx k = (p', mfs', dmu')" 
  and res': "LLL_iso_main p first state g_idx k = (pi', state')" 
shows "state_impl_inv p' mfs' dmu' state'  pi' = p'"
proof (cases "m > 1")
  case True
  from LLL_iso_main_inner[OF impl _ Linv res _ True, unfolded state_iso_inv_def, OF refl, of pi' state'] res' True
  show ?thesis unfolding LLL_iso_main_def by (cases state, auto)
next
  case False
  thus ?thesis using res res' impl unfolding LLL_iso_main_def
    basis_reduction_iso_main.simps[of _ _ _ _ _ k] by auto
qed

lemma LLL_initial: assumes res: "compute_initial_state first = (p, mfs, dmu, g_idx)" 
  and res': "LLL_initial first = (p', state, g_idx')" 
  and m: "m  0" 
shows "state_impl_inv p mfs dmu state  p' = p  g_idx' = g_idx"
proof -
  obtain b gi where norm: "compute_max_gso_norm first dmu_initial = (b,gi)" by force
  obtain P where P: "compute_mod_of_max_gso_norm first b = P" by auto
  define di where "di = IArray.of_fun (λi. if i = 0 then 1 else dμ_impl fs_init !! (i - 1) !! (i - 1)) (Suc m)" 
  note res = res[unfolded compute_initial_state_def Let_def P norm split]
  have di: "di = IArray.of_fun (d_of dmu_initial) (Suc m)" 
    unfolding di_def dmu_initial_def Let_def d_of_def
    by (intro iarray_cong refl if_cong, auto)  
  note norm' = LLL_max_gso_norm_di[OF di m, of first, unfolded norm]
  note res' = res'[unfolded LLL_initial_def Let_def, folded di_def, unfolded norm' P split mod_of_gso_norm[OF m]]
  from res have p: "p = P" and mfs: "mfs = compute_initial_mfs p" and dmu: "dmu = compute_initial_dmu P dmu_initial" 
    and g_idx: "g_idx = gi" 
     by auto
  let ?mods = "IArray.of_fun (λj. P * di !! j * di !! Suc j) (m - 1)" 
  have di': "di = IArray.of_fun (d_of (compute_initial_dmu P dmu_initial)) (Suc m)" 
    unfolding di
    by (intro iarray_cong refl, auto simp: compute_initial_dmu_def d_of_def)
  from res' have p': "p' = P" and g_idx': "g_idx' = gi" and state: 
    "state = (compute_initial_mfs P, IArray.of_fun (λi. IArray.of_fun (λj. dμ_impl fs_init !! i !! j symmod ?mods !! j) i) m, di, ?mods)" 
    by auto
  show ?thesis unfolding mfs p state p' dmu state_impl_inv.simps g_idx' g_idx
  proof (intro conjI refl di' iarray_cong, goal_cases)
    case (1 i j)
    hence "j < m" "Suc j < Suc m" "j < Suc m" "j < m - 1" by auto
    thus ?case unfolding compute_initial_dmu_def di 
        IArray.of_fun_nth[OF j < m]
        IArray.of_fun_nth[OF ‹Suc j < Suc m]
        IArray.of_fun_nth[OF j < Suc m]
        IArray.of_fun_nth[OF j < m - 1]
      unfolding dmu_initial_def Let_def using 1 by auto
  qed
qed 

lemma LLL_add_rows_loop: assumes impl: "state_impl_inv p mfs dmu state" 
  and Linv: "LLL_invariant_mod fs mfs dmu p b first i"
  and res: "basis_reduction_mod_add_rows_loop p mfs dmu i j = (mfs', dmu')" 
  and res': "LLL_add_rows_loop p state i j = state'" 
  and j: "j  i" 
  and i: "i < m" 
shows "state_impl_inv p mfs' dmu' state'"
  using assms(1-5)
proof (induct j arbitrary: fs mfs dmu state)
  case (Suc j)
  note impl = Suc(2)
  note Linv = Suc(3)
  note res = Suc(4)
  note res' = Suc(5)
  note IH = Suc(1)
  from Suc have j: "j < i" and ji: "j  i" by auto
  obtain mfs1 dmu1 where add: "basis_reduction_mod_add_row p mfs dmu i j = (mfs1, dmu1)" by force
  note res = res[unfolded basis_reduction_mod_add_rows_loop.simps Let_def add split]
  obtain state1 where add': "LLL_add_row p state i j = state1" by auto
  note res' = res'[unfolded LLL_add_rows_loop.simps Let_def add']
  note Linvw = LLL_mod_inv_to_weak[OF Linv]
  from LLL_add_row[OF impl Linvw add add' i j]
  have impl1: "state_impl_inv p mfs1 dmu1 state1" .
  from basis_reduction_mod_add_row[OF Linvw add i j] Linv j 
  obtain fs1 where Linv1: "LLL_invariant_mod fs1 mfs1 dmu1 p b first i" by auto
  show ?case using IH[OF impl1 Linv1 res res' ji] .
qed auto

lemma LLL_add_rows_outer_loop: assumes impl: "state_impl_inv p mfs dmu state" 
  and Linv: "LLL_invariant_mod fs mfs dmu p first b m"
  and res: "basis_reduction_mod_add_rows_outer_loop p mfs dmu i = (mfs', dmu')" 
  and res': "LLL_add_rows_outer_loop p state i = state'" 
  and i: "i  m - 1" 
shows "state_impl_inv p mfs' dmu' state'"
  using assms
proof (induct i arbitrary: fs mfs dmu state mfs' dmu' state')
  case (Suc i)
  note impl = Suc(2)
  note Linv = Suc(3)
  note res = Suc(4)
  note res' = Suc(5)
  note i = Suc(6)
  note IH = Suc(1)
  from i have im: "i < m" "i  m - 1" "Suc i < m" by auto
  obtain mfs1 dmu1 where add: "basis_reduction_mod_add_rows_outer_loop p mfs dmu i = (mfs1, dmu1)" by force
  note res = res[unfolded basis_reduction_mod_add_rows_outer_loop.simps Let_def add split]
  obtain state1 where add': "LLL_add_rows_outer_loop p state i = state1" by auto
  note res' = res'[unfolded LLL_add_rows_outer_loop.simps Let_def add']
  from IH[OF impl Linv add add' im(2)] 
  have impl1: "state_impl_inv p mfs1 dmu1 state1" .
  from basis_reduction_mod_add_rows_outer_loop_inv[OF Linv add[symmetric] im(1)]
  obtain fs1 where Linv1: "LLL_invariant_mod fs1 mfs1 dmu1 p first b m" by auto
  from basis_reduction_mod_add_rows_loop_inv'[OF Linv1 res im(3)] obtain fs' where 
    Linv': "LLL_invariant_mod fs' mfs' dmu' p first b m" by auto
  from LLL_add_rows_loop[OF impl1 LLL_invariant_mod_to_weak_m_to_i(1)[OF Linv1] res res' le_refl im(3)] i
  show ?case by auto
qed auto

subsection ‹Soundness of implementation›

text ‹We just prove that the concrete implementations have the same input-output-behaviour as
  the abstract versions of Storjohann's algorithms.›

lemma LLL_reduce_basis: "LLL_reduce_basis = reduce_basis_mod" 
proof (cases "m = 0")
  case True
  from LLL_invD[OF reduce_basis_mod_inv[OF refl]] True 
  have "reduce_basis_mod = []" by auto
  thus ?thesis using True unfolding LLL_reduce_basis_def by auto
next
  case False
  hence idm: "(m = 0) = False" by auto
  let ?first = False
  obtain p1 mfs1 dmu1 g_idx1 where init: "compute_initial_state ?first = (p1, mfs1, dmu1,g_idx1)" 
    by (metis prod_cases3)
  obtain p1' state1 g_idx1' where init': "LLL_initial ?first = (p1', state1, g_idx1')" 
    by (metis prod.exhaust)
  from LLL_initial[OF init init' False]
  have impl1: "state_impl_inv p1 mfs1 dmu1 state1" and id: "p1' = p1" "g_idx1' = g_idx1" by auto
  from LLL_initial_invariant_mod[OF init] obtain fs1 b1 where 
    inv1: "LLL_invariant_mod fs1 mfs1 dmu1 p1 ?first b1 0" by auto
  obtain p2 mfs2 dmu2 where main: "basis_reduction_mod_main p1 ?first mfs1 dmu1 g_idx1 0 0 = (p2, mfs2, dmu2)" 
    by (metis prod_cases3)
  from basis_reduction_mod_main[OF inv1 main] obtain fs2 b2 where 
    inv2: " LLL_invariant_mod fs2 mfs2 dmu2 p2 ?first b2 m" by auto  
  obtain p2' state2 where main': "LLL_main p1 ?first state1 g_idx1 0 0 = (p2', state2)" 
    by (metis prod.exhaust)
  from LLL_main[OF impl1 inv1 main, unfolded id, OF main']
  have impl2: "state_impl_inv p2 mfs2 dmu2 state2" and p2: "p2' = p2" by auto
  obtain mfs3 dmu3 where outer: "basis_reduction_mod_add_rows_outer_loop p2 mfs2 dmu2 (m - 1) = (mfs3, dmu3)" by force
  obtain mfsi3 dmui3 di3 mods3 where outer': "LLL_add_rows_outer_loop p2 state2 (m - 1) = (mfsi3, dmui3, di3, mods3)" 
    by (metis prod_cases4)
  from LLL_add_rows_outer_loop[OF impl2 inv2 outer outer' le_refl] 
  have "state_impl_inv p2 mfs3 dmu3 (mfsi3, dmui3, di3, mods3)" .
  hence identity: "mfs3 = mfsi3" unfolding state_impl_inv.simps by auto
  note res = reduce_basis_mod_def[unfolded init main split Let_def outer]
  note res' = LLL_reduce_basis_def[unfolded init' Let_def main' id split p2 outer' idm if_False]
  show ?thesis unfolding res res' identity ..
qed

lemma LLL_reduce_basis_iso: "LLL_reduce_basis_iso = reduce_basis_iso" 
proof (cases "m = 0")
  case True
  from LLL_invD[OF reduce_basis_iso_inv[OF refl]] True 
  have "reduce_basis_iso = []" by auto
  thus ?thesis using True unfolding LLL_reduce_basis_iso_def by auto
next
  case False
  hence idm: "(m = 0) = False" by auto
  let ?first = False
  obtain p1 mfs1 dmu1 g_idx1 where init: "compute_initial_state ?first = (p1, mfs1, dmu1, g_idx1)" 
    by (metis prod_cases3)
  obtain p1' state1 g_idx1' where init': "LLL_initial ?first = (p1', state1, g_idx1')" 
    by (metis prod.exhaust)
  from LLL_initial[OF init init' False]
  have impl1: "state_impl_inv p1 mfs1 dmu1 state1" and id: "p1' = p1" "g_idx1' = g_idx1" by auto
  from LLL_initial_invariant_mod[OF init] obtain fs1 b1 where 
    inv1: "LLL_invariant_mod_weak fs1 mfs1 dmu1 p1 ?first b1" 
    by (auto simp: LLL_invariant_mod_weak_def LLL_invariant_mod_def)
  obtain p2 mfs2 dmu2 where main: "basis_reduction_iso_main p1 ?first mfs1 dmu1 g_idx1 0 = (p2, mfs2, dmu2)" 
    by (metis prod_cases3)
  from basis_reduction_iso_main[OF inv1 main] obtain fs2 b2 where 
    inv2: " LLL_invariant_mod fs2 mfs2 dmu2 p2 ?first b2 m" by auto  
  obtain p2' state2 where main': "LLL_iso_main p1 ?first state1 g_idx1 0 = (p2', state2)" 
    by (metis prod.exhaust)
  from LLL_iso_main[OF impl1 inv1 main, unfolded id, OF main']
  have impl2: "state_impl_inv p2 mfs2 dmu2 state2" and p2: "p2' = p2" by auto
  obtain mfs3 dmu3 where outer: "basis_reduction_mod_add_rows_outer_loop p2 mfs2 dmu2 (m - 1) = (mfs3, dmu3)" by force
  obtain mfsi3 dmui3 di3 mods3 where outer': "LLL_add_rows_outer_loop p2 state2 (m - 1) = (mfsi3, dmui3, di3, mods3)" 
    by (metis prod_cases4)
  from LLL_add_rows_outer_loop[OF impl2 inv2 outer outer' le_refl] 
  have "state_impl_inv p2 mfs3 dmu3 (mfsi3, dmui3, di3, mods3)" .
  hence identity: "mfs3 = mfsi3" unfolding state_impl_inv.simps by auto
  note res = reduce_basis_iso_def[unfolded init main split Let_def outer]
  note res' = LLL_reduce_basis_iso_def[unfolded init' Let_def main' id split p2 outer' idm if_False]
  show ?thesis unfolding res res' identity ..
qed

lemma LLL_short_vector: assumes m: "m  0" 
  shows "LLL_short_vector = short_vector_mod" 
proof -
  let ?first = True
  obtain p1 mfs1 dmu1 g_idx1 where init: "compute_initial_state ?first = (p1, mfs1, dmu1,g_idx1)" 
    by (metis prod_cases3)
  obtain p1' state1 g_idx1' where init': "LLL_initial ?first = (p1', state1, g_idx1')" 
    by (metis prod.exhaust)
  from LLL_initial[OF init init' m]
  have impl1: "state_impl_inv p1 mfs1 dmu1 state1" and id: "p1' = p1" "g_idx1' = g_idx1" by auto
  from LLL_initial_invariant_mod[OF init] obtain fs1 b1 where 
    inv1: "LLL_invariant_mod fs1 mfs1 dmu1 p1 ?first b1 0" by auto
  obtain p2 mfs2 dmu2 where main: "basis_reduction_mod_main p1 ?first mfs1 dmu1 g_idx1 0 0 = (p2, mfs2, dmu2)" 
    by (metis prod_cases3)
  from basis_reduction_mod_main[OF inv1 main] obtain fs2 b2 where 
    inv2: " LLL_invariant_mod fs2 mfs2 dmu2 p2 ?first b2 m" by auto  
  obtain p2' mfsi2 dmui2 di2 mods2 where main': "LLL_main p1 ?first state1 g_idx1 0 0 = (p2', (mfsi2, dmui2, di2, mods2))" 
    by (metis prod.exhaust)
  from LLL_main[OF impl1 inv1 main, unfolded id, OF main']
  have impl2: "state_impl_inv p2 mfs2 dmu2 (mfsi2, dmui2, di2, mods2)" and p2: "p2' = p2" by auto
  hence identity: "mfs2 = mfsi2" unfolding state_impl_inv.simps by auto
  note res = short_vector_mod_def[unfolded init main split Let_def]
  note res' = LLL_short_vector_def[unfolded init' Let_def main' id split p2]
  show ?thesis unfolding res res' identity ..
qed

lemma LLL_short_vector_iso: assumes m: "m  0" 
  shows "LLL_short_vector_iso = short_vector_iso" 
proof -
  let ?first = True
  obtain p1 mfs1 dmu1 g_idx1 where init: "compute_initial_state ?first = (p1, mfs1, dmu1,g_idx1)" 
    by (metis prod_cases3)
  obtain p1' state1 g_idx1' where init': "LLL_initial ?first = (p1', state1, g_idx1')" 
    by (metis prod.exhaust)
  from LLL_initial[OF init init' m]
  have impl1: "state_impl_inv p1 mfs1 dmu1 state1" and id: "p1' = p1" "g_idx1' = g_idx1" by auto
  from LLL_initial_invariant_mod[OF init] obtain fs1 b1 where 
    inv1: "LLL_invariant_mod_weak fs1 mfs1 dmu1 p1 ?first b1" 
    by (auto simp: LLL_invariant_mod_weak_def LLL_invariant_mod_def)
  obtain p2 mfs2 dmu2 where main: "basis_reduction_iso_main p1 ?first mfs1 dmu1 g_idx1 0 = (p2, mfs2, dmu2)" 
    by (metis prod_cases3)
  from basis_reduction_iso_main[OF inv1 main] obtain fs2 b2 where 
    inv2: " LLL_invariant_mod fs2 mfs2 dmu2 p2 ?first b2 m" by auto  
  obtain p2' mfsi2 dmui2 di2 mods2 where main': "LLL_iso_main p1 ?first state1 g_idx1 0 = (p2', (mfsi2, dmui2, di2, mods2))" 
    by (metis prod.exhaust)
  from LLL_iso_main[OF impl1 inv1 main, unfolded id, OF main']
  have impl2: "state_impl_inv p2 mfs2 dmu2 (mfsi2, dmui2, di2, mods2)" and p2: "p2' = p2" by auto
  hence identity: "mfs2 = mfsi2" unfolding state_impl_inv.simps by auto
  note res = short_vector_iso_def[unfolded init main split Let_def]
  note res' = LLL_short_vector_iso_def[unfolded init' Let_def main' id split p2]
  show ?thesis unfolding res res' identity ..
qed

end

end

Theory Uniqueness_Hermite

section ‹Generalization of the statement about the uniqueness of the Hermite normal form›

theory Uniqueness_Hermite
imports Hermite.Hermite
begin

(*This file presents a generalized version of the theorem Hermite_unique when applied to integer
matrices. More concretely, instead of assuming invertibility over Z of the input matrix A, we now 
assume invertibility over Q. Only some changes to adapt the original proof are required.*)

instance int :: bezout_ring_div
proof qed

lemma map_matrix_rat_of_int_mult:
  shows "map_matrix rat_of_int (A**B) = (map_matrix rat_of_int A)**(map_matrix rat_of_int B)" 
  unfolding map_matrix_def matrix_matrix_mult_def by auto

lemma det_map_matrix:
  fixes A :: "int^'n::mod_type^'n::mod_type"
  shows "det (map_matrix rat_of_int A) = rat_of_int (det A)" 
  unfolding map_matrix_def unfolding Determinants.det_def by auto

lemma inv_Z_imp_inv_Q:
  fixes A :: "int^'n::mod_type^'n::mod_type"
  assumes inv_A: "invertible A"
  shows "invertible (map_matrix rat_of_int A)"
proof -
  have "is_unit (det A)" using inv_A invertible_iff_is_unit by blast
  hence "is_unit (det (map_matrix rat_of_int A))"
    by (simp add: det_map_matrix dvd_if_abs_eq)
  thus ?thesis using invertible_iff_is_unit by blast
qed

lemma upper_triangular_Z_eq_Q:
  "upper_triangular (map_matrix rat_of_int A) = upper_triangular A" 
  unfolding upper_triangular_def by auto

lemma invertible_and_upper_diagonal_not0:
  fixes H :: "int^'n::mod_type^'n::mod_type"
  assumes inv_H: "invertible (map_matrix rat_of_int H)" and up_H: "upper_triangular H"
  shows "H $ i $ i  0"
proof -
  let ?RAT_H = "(map_matrix rat_of_int H)"
  have up_RAT_H: "upper_triangular ?RAT_H"
    using up_H unfolding upper_triangular_def by auto
  have "is_unit (det ?RAT_H)" using inv_H using invertible_iff_is_unit by blast
  hence "?RAT_H $ i $ i  0" using inv_H up_RAT_H is_unit_diagonal
    by (metis not_is_unit_0)
  thus ?thesis by auto
qed

lemma diagonal_least_nonzero:
  fixes H :: "int^'n::mod_type^'n::mod_type"
  assumes H: "Hermite associates residues H"
  and inv_H: "invertible (map_matrix rat_of_int H)" and up_H: "upper_triangular H"
  shows "(LEAST n. H $ i $ n  0) = i"
proof (rule Least_equality)
  show "H $ i $ i  0" by (rule invertible_and_upper_diagonal_not0[OF inv_H up_H])
  fix y
  assume Hiy: "H $ i $ y  0"
  show "i  y" 
    using up_H unfolding upper_triangular_def
    by (metis (poly_guards_query) Hiy not_less)
qed

lemma diagonal_in_associates:
  fixes H :: "int^'n::mod_type^'n::mod_type"
  assumes H: "Hermite associates residues H"
  and inv_H: "invertible (map_matrix rat_of_int H)" and up_H: "upper_triangular H"
  shows "H $ i $ i  associates"
proof -
  have "H $ i $ i  0" by (rule invertible_and_upper_diagonal_not0[OF inv_H up_H])
  hence "¬ is_zero_row i H" unfolding is_zero_row_def is_zero_row_upt_k_def ncols_def by auto
  thus ?thesis using H unfolding Hermite_def unfolding diagonal_least_nonzero[OF H inv_H up_H] 
    by auto
qed

lemma above_diagonal_in_residues:
  fixes H :: "int^'n::mod_type^'n::mod_type"
  assumes H: "Hermite associates residues H"
  and inv_H: "invertible (map_matrix rat_of_int H)" and up_H: "upper_triangular H"
  and j_i: "j<i"
  shows "H $ j $ (LEAST n. H $ i $ n  0)  residues (H $ i $ (LEAST n. H $ i $ n  0))" 
proof -
  have "H $ i $ i  0" by (rule invertible_and_upper_diagonal_not0[OF inv_H up_H])
  hence "¬ is_zero_row i H" unfolding is_zero_row_def is_zero_row_upt_k_def ncols_def by auto
  thus ?thesis using H j_i unfolding Hermite_def unfolding diagonal_least_nonzero[OF H inv_H up_H] 
    by auto
qed


lemma Hermite_unique_generalized:
  fixes K::"int^'n::mod_type^'n::mod_type"
  assumes A_PH: "A = P ** H" 
  and A_QK: "A = Q ** K"
  and inv_A: "invertible (map_matrix rat_of_int A)" (*The original statement assumes "invertible A", 
                                                      that is, invertibility over integers, which is
                                                      more restrictive.*)
  and inv_P: "invertible P"
  and inv_Q: "invertible Q"
  and H: "Hermite associates residues H"
  and K: "Hermite associates residues K"
  shows "H = K"
proof -
  let ?RAT = "map_matrix rat_of_int"
  have cs_residues: "Complete_set_residues residues" using H unfolding Hermite_def by simp
  have inv_H: "invertible (?RAT H)"
  proof -
    have "?RAT A = ?RAT P ** ?RAT H" using A_PH map_matrix_rat_of_int_mult by blast
    thus ?thesis
      by (metis inv_A invertible_left_inverse matrix_inv(1) matrix_mul_assoc)
  qed
  have inv_K: "invertible (?RAT K)"
  proof -
   have "?RAT A = ?RAT Q ** ?RAT K" using A_QK map_matrix_rat_of_int_mult by blast
    thus ?thesis
      by (metis inv_A invertible_left_inverse matrix_inv(1) matrix_mul_assoc)
  qed
  define U where "U = (matrix_inv P)**Q"
  have inv_U: "invertible U" 
    by (metis U_def inv_P inv_Q invertible_def invertible_mult matrix_inv_left matrix_inv_right)
  have H_UK: "H = U ** K" using A_PH A_QK inv_P 
    by (metis U_def matrix_inv_left matrix_mul_assoc matrix_mul_lid)
  have "Determinants.det K *k U = H ** adjugate K"
    unfolding H_UK matrix_mul_assoc[symmetric] mult_adjugate_det matrix_mul_mat ..
  have upper_triangular_H: "upper_triangular H"
    by (metis H Hermite_def echelon_form_imp_upper_triagular)
  have upper_triangular_K: "upper_triangular K" 
    by (metis K Hermite_def echelon_form_imp_upper_triagular)
  have upper_triangular_U: "upper_triangular U" 
  proof -
    have U_H_K: "?RAT U = (?RAT H) ** (matrix_inv (?RAT K))"
      by (metis H_UK inv_K map_matrix_rat_of_int_mult matrix_inv(2) matrix_mul_assoc matrix_mul_rid)
    have up_inv_RAT_K: "upper_triangular (matrix_inv (?RAT K))" using upper_triangular_inverse
      by (simp add: upper_triangular_inverse inv_K upper_triangular_K upper_triangular_Z_eq_Q)
    have "upper_triangular (?RAT U)" unfolding U_H_K 
      by (rule upper_triangular_mult[OF _ up_inv_RAT_K], 
          auto simp add: upper_triangular_H upper_triangular_Z_eq_Q)
    thus ?thesis using upper_triangular_Z_eq_Q by auto
  qed
  have unit_det_U: "is_unit (det U)" by (metis inv_U invertible_iff_is_unit)
  have is_unit_diagonal_U: "(i. is_unit (U $ i $ i))"
    by (rule is_unit_diagonal[OF upper_triangular_U unit_det_U])
  have Uii_1: "(i. (U $ i $ i) = 1)" and Hii_Kii: "(i. (H $ i $ i) = (K $ i $ i))"
  proof (auto)
    fix i
    have Hii: "H $ i $ i  associates" 
      by (rule diagonal_in_associates[OF H inv_H upper_triangular_H])
    have Kii: "K $ i $ i  associates"
      by (rule diagonal_in_associates[OF K inv_K upper_triangular_K])
    have ass_Hii_Kii: "normalize (H $ i $ i) = normalize (K $ i $ i)"
      by (metis H_UK is_unit_diagonal_U normalize_mult_unit_left upper_triangular_K upper_triangular_U upper_triangular_mult_diagonal)
    show Hii_eq_Kii: "H $ i $ i = K $ i $ i"
      by (metis Hermite_def Hii K Kii ass_Hii_Kii in_Ass_not_associated)
    have "H $ i $ i = U $ i $ i * K $ i $ i" 
      by (metis H_UK upper_triangular_K upper_triangular_U upper_triangular_mult_diagonal)
    thus "U $ i $ i = 1" unfolding Hii_eq_Kii mult_cancel_right1
      using inv_K invertible_and_upper_diagonal_not0 upper_triangular_K by blast 
  qed
  have zero_above: "j s. j1  j < ncols A - to_nat s  U $ s $ (s + from_nat j) = 0"
  proof (clarify)
    fix j s assume  "1  j" and "j < ncols A - (to_nat (s::'n))"
    thus "U $ s $ (s + from_nat j) = 0"
    proof (induct j rule: less_induct)
      fix p 
      assume induct_step: "(y. y < p  1  y  y < ncols A - to_nat s  U $ s $ (s + from_nat y) = 0)"
        and p1: "1  p" and p2: "p < ncols A - to_nat s"
      have s_less: "s < s + from_nat p" using p1 p2 unfolding ncols_def
        by (metis One_nat_def add.commute add_diff_cancel_right' add_lessD1 add_to_nat_def 
          from_nat_to_nat_id less_diff_conv neq_iff not_le
          to_nat_from_nat_id to_nat_le zero_less_Suc)
      show "U $ s $ (s + from_nat p) = 0"
      proof -
        have UNIV_rw: "UNIV = insert s (UNIV-{s})" by auto
        have UNIV_s_rw: "UNIV-{s} = insert (s + from_nat p) ((UNIV-{s}) - {s + from_nat p})" 
          using p1 p2 s_less unfolding ncols_def by (auto simp: algebra_simps)
        have sum_rw: "(kUNIV-{s}. U $ s $ k * K $ k $ (s + from_nat p)) 
          = U $ s $ (s + from_nat p) * K $ (s + from_nat p) $ (s + from_nat p) 
          + (k(UNIV-{s})-{s + from_nat p}. U $ s $ k * K $ k $ (s + from_nat p))"
          using UNIV_s_rw sum.insert by (metis (erased, lifting) Diff_iff finite singletonI)
        have sum_0: "(k(UNIV-{s})-{s + from_nat p}. U $ s $ k * K $ k $ (s + from_nat p)) = 0"
        proof (rule sum.neutral, rule)
          fix x assume x: "x  UNIV - {s} - {s + from_nat p}"
          show "U $ s $ x * K $ x $ (s + from_nat p) = 0" 
          proof (cases "x<s")
            case True
            thus ?thesis using upper_triangular_U unfolding upper_triangular_def
              by auto
          next
            case False
            hence x_g_s: "x>s" using x by (metis Diff_iff neq_iff singletonI)
            show ?thesis 
            proof (cases "x<s+from_nat p")
              case True
              define a where "a = to_nat x - to_nat s"
              from x_g_s have "to_nat s < to_nat x" by (rule to_nat_mono)
              hence xa: "x=s+(from_nat a)" unfolding a_def add_to_nat_def
                by (simp add: less_imp_diff_less to_nat_less_card algebra_simps to_nat_from_nat_id)
              have "U $ s $ x =0" 
              proof (unfold xa, rule induct_step)
                show a_p: "a<p" unfolding a_def using p2 unfolding ncols_def 
                proof -
                  have "x < from_nat (to_nat s + to_nat (from_nat p::'n))"
                    by (metis (no_types) True add_to_nat_def)
                  hence "to_nat x - to_nat s < to_nat (from_nat p::'n)"
                    by (simp add: add.commute less_diff_conv2 less_imp_le to_nat_le x_g_s)
                  thus "to_nat x - to_nat s < p"
                    by (metis (no_types) from_nat_eq_imp_eq from_nat_to_nat_id le_less_trans 
                        less_imp_le not_le to_nat_less_card)
                qed                    
                show "1  a" 
                  by (auto simp add: a_def p1 p2) (metis Suc_leI to_nat_mono x_g_s zero_less_diff)
                show "a < ncols A - to_nat s" using a_p p2 by auto
              qed
              thus ?thesis by simp
            next
              case False
              hence "x>s+from_nat p" using x_g_s x by auto
              thus ?thesis using upper_triangular_K unfolding upper_triangular_def
                by auto
            qed
          qed 
        qed
        have "H $ s $ (s + from_nat p) = (kUNIV. U $ s $ k * K $ k $ (s + from_nat p))"
          unfolding H_UK matrix_matrix_mult_def by auto
        also have "... = (kinsert s (UNIV-{s}). U $ s $ k * K $ k $ (s + from_nat p))"
          using UNIV_rw by simp
        also have "... = U $ s $ s * K $ s $ (s + from_nat p) 
          + (kUNIV-{s}. U $ s $ k * K $ k $ (s + from_nat p))"
          by (rule sum.insert, simp_all)
        also have "... = U $ s $ s * K $ s $ (s + from_nat p) 
          + U $ s $ (s + from_nat p) * K $ (s + from_nat p) $ (s + from_nat p)"
          unfolding sum_rw sum_0 by simp
        finally have H_s_sp: "H $ s $ (s + from_nat p) 
          = U $ s $ (s + from_nat p) * K $ (s + from_nat p) $ (s + from_nat p) + K $ s $ (s + from_nat p)"
          using Uii_1 by auto
        hence cong_HK: "cong (H $ s $ (s + from_nat p)) (K $ s $ (s + from_nat p)) (K $ (s+from_nat p) $ (s + from_nat p))"
          unfolding cong_def by auto
        have H_s_sp_residues: "(H $ s $ (s + from_nat p))  residues (K $ (s+from_nat p) $ (s + from_nat p))" 
          using above_diagonal_in_residues[OF H inv_H upper_triangular_H s_less]
          unfolding diagonal_least_nonzero[OF H inv_H upper_triangular_H]
          by (metis Hii_Kii)
        have K_s_sp_residues: "(K $ s $ (s + from_nat p))  residues (K $ (s+from_nat p) $ (s + from_nat p))"
          using above_diagonal_in_residues[OF K inv_K upper_triangular_K s_less]
          unfolding diagonal_least_nonzero[OF K inv_K upper_triangular_K] .
        have Hs_sp_Ks_sp: "(H $ s $ (s + from_nat p)) = (K $ s $ (s + from_nat p))"             
          using cong_HK in_Res_not_congruent[OF cs_residues H_s_sp_residues K_s_sp_residues]
          by fast
        have "K $ (s + from_nat p) $ (s + from_nat p)  0"
          using inv_K invertible_and_upper_diagonal_not0 upper_triangular_K by blast
        thus ?thesis unfolding from_nat_1 using H_s_sp unfolding Hs_sp_Ks_sp by auto
      qed 
    qed 
  qed
  have "U = mat 1" 
  proof (unfold mat_def vec_eq_iff, auto)
    fix ia show "U $ ia $ ia = 1" using Uii_1 by simp
    fix i assume i_ia: "i  ia"
    show "U $ i $ ia = 0"
    proof (cases "ia<i")
      case True
      thus ?thesis using upper_triangular_U unfolding upper_triangular_def by auto
    next
      case False
      hence i_less_ia: "i<ia" using i_ia by auto
      define a where "a = to_nat ia - to_nat i"
      have ia_eq: "ia = i + from_nat a" unfolding a_def
        by (metis i_less_ia a_def add_to_nat_def dual_order.strict_iff_order from_nat_to_nat_id 
            le_add_diff_inverse less_imp_diff_less to_nat_from_nat_id to_nat_less_card to_nat_mono)
      have "1  a" unfolding a_def
        by (metis diff_is_0_eq i_less_ia less_one not_less to_nat_mono)
      moreover have "a < ncols A - to_nat i"
        unfolding a_def ncols_def
        by (metis False diff_less_mono not_less to_nat_less_card to_nat_mono')
      ultimately show ?thesis using zero_above unfolding ia_eq by blast
    qed
  qed
  thus ?thesis using H_UK matrix_mul_lid by fast
qed

end

Theory Uniqueness_Hermite_JNF

section ‹Uniqueness of Hermite normal form in JNF›

text ‹This theory contains the proof of the uniqueness theorem of the Hermite normal form in JNF,
moved from HOL Analysis.›

theory Uniqueness_Hermite_JNF
  imports 
  Hermite.Hermite
  Uniqueness_Hermite
  Smith_Normal_Form.SNF_Missing_Lemmas
  Smith_Normal_Form.Mod_Type_Connect
  Smith_Normal_Form.Finite_Field_Mod_Type_Connection
begin  

hide_const (open) residues

text ‹We first define some properties that currently exist in HOL Analysis, but not in
JNF, namely a predicate for being in echelon form, another one for being in Hermite normal form,
definition of a row of zeros up to a concrete position, and so on.›

definition is_zero_row_upt_k_JNF :: "nat  => nat =>'a::{zero} mat => bool"
  where "is_zero_row_upt_k_JNF i k A = (j. j < k  A $$ (i,j) = 0)"

definition is_zero_row_JNF :: "nat =>'a::{zero} mat  => bool"
  where "is_zero_row_JNF i A =  (j<dim_col A. A $$ (i, j) = 0)"

lemma echelon_form_def': 
"echelon_form A = (
    (i. is_zero_row i A  ¬ (j. j>i  ¬ is_zero_row j A)) 
      
    (i j. i<j  ¬ (is_zero_row i A)  ¬ (is_zero_row j A) 
           ((LEAST n. A $ i $ n  0) < (LEAST n. A $ j $ n  0))))"
  unfolding echelon_form_def echelon_form_upt_k_def unfolding is_zero_row_def by auto

definition 
  echelon_form_JNF :: "'a::{bezout_ring} mat  bool" 
  where 
  "echelon_form_JNF A = (
    (i<dim_row A. is_zero_row_JNF i A  ¬ (j. j < dim_row A  j>i  ¬ is_zero_row_JNF j A)) 
      
    (i j. i<j  j<dim_row A  ¬ (is_zero_row_JNF i A)  ¬ (is_zero_row_JNF j A) 
           ((LEAST n. A $$ (i, n)  0) < (LEAST n. A $$ (j, n)  0))))"


text ‹Now, we connect the existing definitions in HOL Analysis to the ones just defined in JNF by
means of transfer rules.›

context includes lifting_syntax
begin


lemma HMA_is_zero_row_mod_type[transfer_rule]: 
  "((Mod_Type_Connect.HMA_I) ===> (Mod_Type_Connect.HMA_M :: _  'a :: comm_ring_1 ^ 'n :: mod_type ^ 'm :: mod_type  _) 
    ===> (=)) is_zero_row_JNF is_zero_row"
proof (intro rel_funI, goal_cases)
  case (1 i i' A A')
  note ii' = "1"(1)[transfer_rule]
  note AA' = "1"(2)[transfer_rule]
  have "(j<dim_col A. A $$ (i, j) = 0) = (j. A' $h i' $h j = 0)"
  proof (rule;rule+)
    fix j'::'n assume Aij_0: "j<dim_col A. A $$ (i, j) = 0" 
    define j where "j = mod_type_class.to_nat j'"
    have [transfer_rule]: "Mod_Type_Connect.HMA_I j j'" unfolding Mod_Type_Connect.HMA_I_def j_def by auto
    have A_ij0': "A $$ (i,j) = 0" using Aij_0 unfolding j_def
      by (metis AA' Mod_Type_Connect.HMA_M_def Mod_Type_Connect.from_hmam_def 
          dim_col_mat(1) mod_type_class.to_nat_less_card)
    hence "index_hma A' i' j' = 0" by transfer
    thus "A' $h i' $h j' = 0" unfolding index_hma_def by simp
  next
    fix j assume 1: "j'. A' $h i' $h j' = 0" and 2: "j < dim_col A" 
    define j'::'n where "j' = mod_type_class.from_nat j"
    have [transfer_rule]: "Mod_Type_Connect.HMA_I j j'" unfolding Mod_Type_Connect.HMA_I_def j'_def 
      using Mod_Type.to_nat_from_nat_id[of j, where ?'a = 'n] 2
      using AA' Mod_Type_Connect.dim_col_transfer_rule by force
    have "A' $h i' $h j' = 0" using 1 by auto
    hence "index_hma A' i' j' = 0" unfolding index_hma_def by simp  
    thus "A $$ (i, j) = 0" by transfer
  qed
  thus ?case unfolding is_zero_row_def' is_zero_row_JNF_def by auto
qed

lemma HMA_echelon_form_mod_type[transfer_rule]: 
  "((Mod_Type_Connect.HMA_M :: _  'a ::bezout_ring ^ 'n :: mod_type ^ 'm :: mod_type  _) ===> (=))
  echelon_form_JNF echelon_form"
proof (intro rel_funI, goal_cases)
  case (1 A A')
  note AA' = "1"(1)[transfer_rule]
  have 1: "(i<dim_row A. is_zero_row_JNF i A  ¬ (j < dim_row A. j>i  ¬ is_zero_row_JNF j A))
    = (i. is_zero_row i A'  ¬ (j>i. ¬ is_zero_row j A'))"
  proof (auto)
    fix i' j' assume 1: "i<dim_row A. is_zero_row_JNF i A  (j>i. j < dim_row A  is_zero_row_JNF j A)"
      and 2: "is_zero_row i' A'" and 3: "i' < j'"
    let ?i = "Mod_Type.to_nat i'"
    let ?j = "Mod_Type.to_nat j'"
    have ii'[transfer_rule]: "Mod_Type_Connect.HMA_I ?i i'" and jj'[transfer_rule]: "Mod_Type_Connect.HMA_I ?j j'" 
      unfolding Mod_Type_Connect.HMA_I_def by auto
    have "is_zero_row_JNF ?i A" using 2 by transfer' 
    hence "is_zero_row_JNF ?j A" using 1 3 to_nat_mono
      by (metis AA' Mod_Type_Connect.HMA_M_def Mod_Type_Connect.from_hmam_def
          dim_row_mat(1) mod_type_class.to_nat_less_card)
    thus "is_zero_row j' A'" by transfer'
  next
    fix i j assume 1: "i'. is_zero_row i' A'  (j'>i'. is_zero_row j' A')"
      and 2: "is_zero_row_JNF i A" and 3: "i < j" and 4: "j<dim_row A"
    let ?i' = "Mod_Type.from_nat i::'m"
    let ?j' = "Mod_Type.from_nat j::'m"
    have ii'[transfer_rule]: "Mod_Type_Connect.HMA_I i ?i'"
      unfolding Mod_Type_Connect.HMA_I_def using Mod_Type.to_nat_from_nat_id[of i]
      using 3 4 AA' Mod_Type_Connect.dim_row_transfer_rule less_trans by fastforce
    have jj'[transfer_rule]: "Mod_Type_Connect.HMA_I j ?j'" 
      unfolding Mod_Type_Connect.HMA_I_def  using Mod_Type.to_nat_from_nat_id[of j]
      using 3 4 AA' Mod_Type_Connect.dim_row_transfer_rule less_trans by fastforce
    have "is_zero_row ?i' A'" using 2 by transfer
    moreover have "?i' < ?j'" using 3 4 AA' Mod_Type_Connect.dim_row_transfer_rule from_nat_mono by fastforce
    ultimately have "is_zero_row ?j' A'" using 1 3 by auto
    thus "is_zero_row_JNF j A" by transfer
  qed
  have 2: "((i j. i<j  ¬ (is_zero_row i A')  ¬ (is_zero_row j A') 
     ((LEAST n. A' $h i $h n  0) < (LEAST n. A' $h j $h n  0)))) 
    = (i j. i<j  j<dim_row A  ¬ (is_zero_row_JNF i A)  ¬ (is_zero_row_JNF j A) 
     ((LEAST n. A $$ (i, n)  0) < (LEAST n. A $$ (j, n)  0)))"
  proof (auto)
    fix i j assume 1: "i' j'. i' < j'  ¬ is_zero_row i' A'  ¬ is_zero_row j' A' 
       (LEAST n'. A' $h i' $h n'  0) < (LEAST n'. A' $h j' $h n'  0)"
      and ij: "i < j" and j: "j < dim_row A" and i0: "¬ is_zero_row_JNF i A"
      and j0: "¬ is_zero_row_JNF j A"
    let ?i' = "Mod_Type.from_nat i::'m"
    let ?j' = "Mod_Type.from_nat j::'m"
    have ii'[transfer_rule]: "Mod_Type_Connect.HMA_I i ?i'"
      unfolding Mod_Type_Connect.HMA_I_def using Mod_Type.to_nat_from_nat_id[of i]
      using ij j AA' Mod_Type_Connect.dim_row_transfer_rule less_trans by fastforce
    have jj'[transfer_rule]: "Mod_Type_Connect.HMA_I j ?j'" 
      unfolding Mod_Type_Connect.HMA_I_def  using Mod_Type.to_nat_from_nat_id[of j]
      using ij j AA' Mod_Type_Connect.dim_row_transfer_rule less_trans by fastforce
    have i'0: "¬ is_zero_row ?i' A'" using i0 by transfer
    have j'0: "¬ is_zero_row ?j' A'" using j0 by transfer
    have i'j': "?i' < ?j'"
      using AA' Mod_Type_Connect.dim_row_transfer_rule from_nat_mono ij j by fastforce
    have l1l2: "(LEAST n'. A' $h ?i' $h n'  0) < (LEAST n'. A' $h ?j' $h n'  0)"
      using 1 i'0 j'0 i'j' by auto
    define l1 where "l1 = (LEAST n'. A' $h ?i' $h n'  0)"
    define l2 where "l2 = (LEAST n'. A' $h ?j' $h n'  0)"
    let ?least_n1 = "Mod_Type.to_nat l1"
    let ?least_n2 = "Mod_Type.to_nat l2"
    have l1[transfer_rule]: "Mod_Type_Connect.HMA_I ?least_n1 l1" and [transfer_rule]: "Mod_Type_Connect.HMA_I ?least_n2 l2"
      unfolding Mod_Type_Connect.HMA_I_def by auto
    have "(LEAST n. A $$ (i, n)  0) = ?least_n1" 
    proof (rule Least_equality)
      obtain n' where n'1: "A $$ (i,n')  0" and n'2: "n'<dim_col A"
        using i0 unfolding is_zero_row_JNF_def by auto
      let ?n' = "Mod_Type.from_nat n'::'n"
      have n'n'[transfer_rule]: "Mod_Type_Connect.HMA_I n' ?n'"
        unfolding Mod_Type_Connect.HMA_I_def using Mod_Type.to_nat_from_nat_id n'2
        using AA' Mod_Type_Connect.dim_col_transfer_rule by fastforce
      have "index_hma A' ?i' ?n'  0" using n'1 by transfer
      hence A'i'n': "A' $h ?i' $h ?n'  0" unfolding index_hma_def by simp
      have least_le_n': "(LEAST n. A $$ (i, n)  0)   n'" by (simp add: Least_le n'1)
      have l1_le_n': "l1  ?n'" by (simp add: A'i'n' Least_le l1_def)
      have "A $$ (i, ?least_n1) = index_hma A' ?i' l1" by (transfer, simp)
      also have "... = A' $h mod_type_class.from_nat i $h l1" unfolding index_hma_def by simp
      also have "...  0" unfolding l1_def by (metis (mono_tags, lifting) LeastI i'0 is_zero_row_def')
      finally show "A $$ (i, mod_type_class.to_nat l1)  0" .
      fix y assume Aiy: "A $$ (i, y)  0"
      let ?y' = "Mod_Type.from_nat y::'n"
      show "Mod_Type.to_nat l1  y"
      proof (cases "yn'")
        case True
        hence y: "y < dim_col A" using n'2 by auto
        have yy'[transfer_rule]: "Mod_Type_Connect.HMA_I y ?y'" unfolding Mod_Type_Connect.HMA_I_def
          apply (rule Mod_Type.to_nat_from_nat_id[symmetric])
          using y Mod_Type_Connect.dim_col_transfer_rule[OF AA'] by auto
        have "Mod_Type.to_nat l1  Mod_Type.to_nat ?y'"
        proof (rule to_nat_mono')
          have "index_hma A' ?i' ?y'  0" using Aiy by transfer
          hence "A' $h ?i' $h ?y'  0" unfolding index_hma_def by simp
          thus "l1  ?y'" unfolding l1_def by (simp add: Least_le)
        qed
          then show ?thesis by (metis Mod_Type_Connect.HMA_I_def yy')
        next
          case False
          hence "n' < y" by auto
          then show ?thesis
            by (metis False Mod_Type_Connect.HMA_I_def dual_order.trans l1_le_n' linear n'n' to_nat_mono')
        qed
      qed
      moreover have "(LEAST n. A $$ (j, n)  0) = ?least_n2"
      proof (rule Least_equality)
        obtain n' where n'1: "A $$ (j,n')  0" and n'2: "n'<dim_col A"
        using j0 unfolding is_zero_row_JNF_def by auto
      let ?n' = "Mod_Type.from_nat n'::'n"
      have n'n'[transfer_rule]: "Mod_Type_Connect.HMA_I n' ?n'" 
        unfolding Mod_Type_Connect.HMA_I_def using Mod_Type.to_nat_from_nat_id n'2
        using AA' Mod_Type_Connect.dim_col_transfer_rule by fastforce
      have "index_hma A' ?j' ?n'  0" using n'1 by transfer
      hence A'i'n': "A' $h ?j' $h ?n'  0" unfolding index_hma_def by simp
      have least_le_n': "(LEAST n. A $$ (j, n)  0)   n'" by (simp add: Least_le n'1)
      have l1_le_n': "l2  ?n'" by (simp add: A'i'n' Least_le l2_def)
      have "A $$ (j, ?least_n2) = index_hma A' ?j' l2" by (transfer, simp)
      also have "... = A' $h ?j' $h l2" unfolding index_hma_def by simp
      also have "...  0" unfolding l2_def by (metis (mono_tags, lifting) LeastI j'0 is_zero_row_def')
      finally show "A $$ (j, mod_type_class.to_nat l2)  0" .
      fix y assume Aiy: "A $$ (j, y)  0"
      let ?y' = "Mod_Type.from_nat y::'n"
      show "Mod_Type.to_nat l2  y"
      proof (cases "yn'")
        case True
        hence y: "y < dim_col A" using n'2 by auto
        have yy'[transfer_rule]: "Mod_Type_Connect.HMA_I y ?y'" unfolding Mod_Type_Connect.HMA_I_def
          apply (rule Mod_Type.to_nat_from_nat_id[symmetric])
          using y Mod_Type_Connect.dim_col_transfer_rule[OF AA'] by auto
        have "Mod_Type.to_nat l2  Mod_Type.to_nat ?y'"
        proof (rule to_nat_mono')
          have "index_hma A' ?j' ?y'  0" using Aiy by transfer
          hence "A' $h ?j' $h ?y'  0" unfolding index_hma_def by simp
          thus "l2  ?y'" unfolding l2_def by (simp add: Least_le)
        qed
          then show ?thesis by (metis Mod_Type_Connect.HMA_I_def yy')
        next
          case False
          hence "n' < y" by auto
          then show ?thesis
            by (metis False Mod_Type_Connect.HMA_I_def dual_order.trans l1_le_n' linear n'n' to_nat_mono')
        qed
      qed
      ultimately show "(LEAST n. A $$ (i, n)  0) < (LEAST n. A $$ (j, n)  0)"
        using l1l2 unfolding l1_def l2_def by (simp add: to_nat_mono)
    next
      fix i' j' assume 1: "i j. i < j  j < dim_row A  ¬ is_zero_row_JNF i A  ¬ is_zero_row_JNF j A 
       (LEAST n. A $$ (i, n)  0) < (LEAST n. A $$ (j, n)  0)"
       and i'j': "i' < j'" and i': "¬ is_zero_row i' A'" and j': "¬ is_zero_row j' A'"
      let ?i = "Mod_Type.to_nat i'"
      let ?j = "Mod_Type.to_nat j'"
      have [transfer_rule]: "Mod_Type_Connect.HMA_I ?i i'" 
        and [transfer_rule]: "Mod_Type_Connect.HMA_I ?j j'"
        unfolding Mod_Type_Connect.HMA_I_def by auto
      have i: "¬ is_zero_row_JNF ?i A" using i' by transfer'
      have j: "¬ is_zero_row_JNF ?j A" using j' by transfer'
      have ij: "?i < ?j" using i'j' to_nat_mono by blast
      have j_dim_row: "?j < dim_row A" 
        using AA' Mod_Type_Connect.dim_row_transfer_rule mod_type_class.to_nat_less_card by fastforce
      have least_ij: "(LEAST n. A $$ (?i, n)  0) < (LEAST n. A $$ (?j, n)  0)"
        using i j ij j_dim_row 1 by auto
      define l1 where "l1 = (LEAST n'. A $$ (?i, n')  0)"
      define l2 where "l2 = (LEAST n'. A $$ (?j, n')  0)"
      let ?least_n1 = "Mod_Type.from_nat l1::'n"
      let ?least_n2 = "Mod_Type.from_nat l2::'n"
      have l1_dim_col: "l1 < dim_col A"
        by (smt is_zero_row_JNF_def j l1_def leI le_less_trans least_ij less_trans not_less_Least)
      have l2_dim_col: "l2 < dim_col A"
        by (metis (mono_tags, lifting) Least_le is_zero_row_JNF_def j l2_def le_less_trans)
      have [transfer_rule]: "Mod_Type_Connect.HMA_I l1 ?least_n1" unfolding Mod_Type_Connect.HMA_I_def
        using AA' Mod_Type_Connect.dim_col_transfer_rule l1_dim_col Mod_Type.to_nat_from_nat_id
        by fastforce
      have [transfer_rule]: "Mod_Type_Connect.HMA_I l2 ?least_n2" unfolding Mod_Type_Connect.HMA_I_def
        using AA' Mod_Type_Connect.dim_col_transfer_rule l2_dim_col Mod_Type.to_nat_from_nat_id
        by fastforce
      have "(LEAST n. A' $h i' $h n  0) = ?least_n1"
      proof (rule Least_equality)
        obtain n' where n'1: "A' $h i' $h n'  0" using i' unfolding is_zero_row_def' by auto
        have "A' $h i' $h ?least_n1 = index_hma A' i' ?least_n1" unfolding index_hma_def by simp
        also have "... = A$$ (?i, l1)"  by (transfer, simp)
        also have "...  0" by (metis (mono_tags, lifting) LeastI i is_zero_row_JNF_def l1_def)
        finally show "A' $h i' $h ?least_n1  0" .
      next
        fix y assume y: "A' $h i' $h y  0"
        let ?y' = "Mod_Type.to_nat y"
        have [transfer_rule]: "Mod_Type_Connect.HMA_I ?y' y" unfolding Mod_Type_Connect.HMA_I_def by simp
        have "?least_n1  Mod_Type.from_nat ?y'"
        proof (unfold l1_def, rule from_nat_mono')                      
          show "Mod_Type.to_nat y < CARD('n)" by (simp add: mod_type_class.to_nat_less_card)
          have *: "A $$ (mod_type_class.to_nat i', mod_type_class.to_nat y)  0" 
            using y[unfolded index_hma_def[symmetric]] by transfer'
          show "(LEAST n'. A $$ (mod_type_class.to_nat i', n')  0)  mod_type_class.to_nat y" 
            by (rule Least_le, simp add: *)
        qed
        also have "... = y" by simp
        finally show "?least_n1  y" .
      qed
      moreover have "(LEAST n. A' $h j' $h n  0) = ?least_n2"
      proof (rule Least_equality)
        obtain n' where n'1: "A' $h j' $h n'  0" using j' unfolding is_zero_row_def' by auto
        have "A' $h j' $h ?least_n2 = index_hma A' j' ?least_n2" unfolding index_hma_def by simp
        also have "... = A$$ (?j, l2)"  by (transfer, simp)
        also have "...  0" by (metis (mono_tags, lifting) LeastI j is_zero_row_JNF_def l2_def)
        finally show "A' $h j' $h ?least_n2  0" .
      next
        fix y assume y: "A' $h j' $h y  0"
        let ?y' = "Mod_Type.to_nat y"
        have [transfer_rule]: "Mod_Type_Connect.HMA_I ?y' y" unfolding Mod_Type_Connect.HMA_I_def by simp
        have "?least_n2  Mod_Type.from_nat ?y'"
        proof (unfold l2_def, rule from_nat_mono')                      
          show "Mod_Type.to_nat y < CARD('n)" by (simp add: mod_type_class.to_nat_less_card)
          have *: "A $$ (mod_type_class.to_nat j', mod_type_class.to_nat y)  0" 
            using y[unfolded index_hma_def[symmetric]] by transfer'
          show "(LEAST n'. A $$ (mod_type_class.to_nat j', n')  0)  mod_type_class.to_nat y" 
            by (rule Least_le, simp add: *)
        qed
        also have "... = y" by simp
        finally show "?least_n2  y" .
      qed
      ultimately show "(LEAST n. A' $h i' $h n  0) < (LEAST n. A' $h j' $h n  0)" using least_ij
        unfolding l1_def l2_def
        using AA' Mod_Type_Connect.dim_col_transfer_rule from_nat_mono l2_def l2_dim_col
        by fastforce
    qed
   show ?case unfolding echelon_form_JNF_def echelon_form_def' using 1 2 by auto
qed


definition Hermite_JNF :: "'a::{bezout_ring_div,normalization_semidom} set  ('a  'a set)  'a mat  bool"
  where "Hermite_JNF associates residues A = (
  Complete_set_non_associates associates  (Complete_set_residues residues)  echelon_form_JNF A 
   (i<dim_row A. ¬ is_zero_row_JNF i A  A $$ (i, LEAST n. A $$ (i, n)  0)  associates)
   (i<dim_row A. ¬ is_zero_row_JNF i A  (j. j<i  A $$ (j, (LEAST n. A $$ (i, n)  0)) 
      residues (A $$ (i,(LEAST n. A $$ (i,n)  0)))
  )))"


lemma HMA_LEAST[transfer_rule]:
  assumes AA': "(Mod_Type_Connect.HMA_M :: _  'a :: comm_ring_1 ^ 'n :: mod_type ^ 'm :: mod_type  _) A A'"
  and ii': "Mod_Type_Connect.HMA_I i i'" and zero_i: "¬ is_zero_row_JNF i A"
shows "Mod_Type_Connect.HMA_I (LEAST n. A $$ (i, n)  0) (LEAST n. index_hma A' i' n  0)"
proof -
  define l where "l = (LEAST n'. A' $h i' $h n'  0)"
  let ?least_n2 = "Mod_Type.to_nat l"
  note AA'[transfer_rule] ii'[transfer_rule]
  have [transfer_rule]: "Mod_Type_Connect.HMA_I ?least_n2 l"
    by (simp add: Mod_Type_Connect.HMA_I_def)
  have zero_i': "¬ is_zero_row i' A'" using zero_i by transfer
  have "(LEAST n. A $$ (i, n)  0) = ?least_n2"
      proof (rule Least_equality)
        obtain n' where n'1: "A $$ (i,n')  0" and n'2: "n'<dim_col A"
        using zero_i unfolding is_zero_row_JNF_def by auto
      let ?n' = "Mod_Type.from_nat n'::'n"
      have n'n'[transfer_rule]: "Mod_Type_Connect.HMA_I n' ?n'" 
        unfolding Mod_Type_Connect.HMA_I_def using Mod_Type.to_nat_from_nat_id n'2
        using AA' Mod_Type_Connect.dim_col_transfer_rule by fastforce
      have "index_hma A' i' ?n'  0" using n'1 by transfer
      hence A'i'n': "A' $h i' $h ?n'  0" unfolding index_hma_def by simp
      have least_le_n': "(LEAST n. A $$ (i, n)  0)   n'" by (simp add: Least_le n'1)
      have l1_le_n': "l  ?n'" by (simp add: A'i'n' Least_le l_def)
      have "A $$ (i, ?least_n2) = index_hma A' i' l" by (transfer, simp)
      also have "... = A' $h i' $h l" unfolding index_hma_def by simp
      also have "...  0" unfolding l_def by (metis (mono_tags) A'i'n' LeastI)
      finally show "A $$ (i, mod_type_class.to_nat l)  0" .
      fix y assume Aiy: "A $$ (i, y)  0"
      let ?y' = "Mod_Type.from_nat y::'n"
      show "Mod_Type.to_nat l  y"
      proof (cases "yn'")
        case True
        hence y: "y < dim_col A" using n'2 by auto
        have yy'[transfer_rule]: "Mod_Type_Connect.HMA_I y ?y'" unfolding Mod_Type_Connect.HMA_I_def
          apply (rule Mod_Type.to_nat_from_nat_id[symmetric])
          using y Mod_Type_Connect.dim_col_transfer_rule[OF AA'] by auto
        have "Mod_Type.to_nat l  Mod_Type.to_nat ?y'"
        proof (rule to_nat_mono')
          have "index_hma A' i' ?y'  0" using Aiy by transfer
          hence "A' $h i' $h ?y'  0" unfolding index_hma_def by simp
          thus "l  ?y'" unfolding l_def by (simp add: Least_le)
        qed
          then show ?thesis by (metis Mod_Type_Connect.HMA_I_def yy')
        next
          case False
          hence "n' < y" by auto
          then show ?thesis
            by (metis False Mod_Type_Connect.HMA_I_def dual_order.trans l1_le_n' linear n'n' to_nat_mono')
        qed
      qed
      thus ?thesis unfolding Mod_Type_Connect.HMA_I_def l_def index_hma_def by auto
qed


lemma element_least_not_zero_eq_HMA_JNF:
  fixes A':: "'a :: comm_ring_1 ^ 'n :: mod_type ^ 'm :: mod_type"
  assumes AA': "Mod_Type_Connect.HMA_M A A'" and jj': "Mod_Type_Connect.HMA_I j j'"
    and ii': "Mod_Type_Connect.HMA_I i i'" and zero_i': "¬ is_zero_row i' A'"
  shows "A $$ (j, LEAST n. A $$ (i, n)  0) = A' $h j' $h (LEAST n. A' $h i' $h n  0)" 
proof -
  note AA'[transfer_rule] jj'[transfer_rule] ii'[transfer_rule]
  have [transfer_rule]: "Mod_Type_Connect.HMA_I (LEAST n. A $$ (i, n)  0) (LEAST n. index_hma A' i' n  0)"
    by (rule HMA_LEAST[OF AA' ii'], insert zero_i', transfer, simp)
  have "A' $h j' $h (LEAST n. A' $h i' $h n  0) = index_hma A' j' (LEAST n. index_hma A' i' n  0)" 
    unfolding index_hma_def by simp
  also have "... = A $$ (j, LEAST n. A $$ (i, n)  0)" by (transfer', simp)
  finally show ?thesis by simp
qed


lemma HMA_Hermite[transfer_rule]:
  shows "((Mod_Type_Connect.HMA_M :: _  'a :: {bezout_ring_div,normalization_semidom} ^ 'n :: mod_type ^ 'm :: mod_type  _) ===> (=)) 
  (Hermite_JNF associates residues) (Hermite associates residues)"
proof (intro rel_funI, goal_cases)
  case (1 A A')
  note AA' = "1"(1)[transfer_rule]
  have 1: "echelon_form A' = echelon_form_JNF A" by (transfer, simp)
  have 2: "(i<dim_row A. ¬ is_zero_row_JNF i A  A $$ (i, LEAST n. A $$ (i, n)  0)  associates) =
  (i. ¬ is_zero_row i A'  A' $h i $h (LEAST n. A' $h i $h n  0)  associates)" (is "?lhs = ?rhs")
  proof 
    assume lhs: "?lhs"
    show "?rhs"
    proof (rule allI, rule impI)
      fix i' assume zero_i': "¬ is_zero_row i' A'" 
      let ?i = "Mod_Type.to_nat i'"
      have ii'[transfer_rule]: "Mod_Type_Connect.HMA_I ?i i'" unfolding Mod_Type_Connect.HMA_I_def by simp
      have [simp]: "?i < dim_row A" using Mod_Type.to_nat_less_card[of i']
        using AA' Mod_Type_Connect.dim_row_transfer_rule by fastforce
      have zero_i: "¬ is_zero_row_JNF ?i A" using zero_i' by transfer
      have [transfer_rule]: "Mod_Type_Connect.HMA_I (LEAST n. A $$ (?i, n)  0) (LEAST n. index_hma A' i' n  0)"
        by (rule HMA_LEAST[OF AA' ii'], insert zero_i', transfer, simp)
      have "A' $h i' $h (LEAST n. A' $h i' $h n  0) = A $$ (?i, LEAST n. A $$ (?i, n)  0)"
        by (rule element_least_not_zero_eq_HMA_JNF[OF AA' ii' ii' zero_i', symmetric])
      also have "...  associates" using lhs zero_i by simp  
      finally show "A' $h i' $h (LEAST n. A' $h i' $h n  0)  associates" .
    qed
  next
    assume rhs: "?rhs"
    show "?lhs"
    proof (rule allI, rule impI, rule impI)
      fix i assume zero_i: "¬ is_zero_row_JNF i A" and i: "i < dim_row A"
      let ?i' = "Mod_Type.from_nat i :: 'm"
      have ii'[transfer_rule]: "Mod_Type_Connect.HMA_I i ?i'" unfolding Mod_Type_Connect.HMA_I_def
        using Mod_Type.to_nat_from_nat_id AA' Mod_Type_Connect.dim_row_transfer_rule i by fastforce
      have zero_i': "¬ is_zero_row ?i' A'" using zero_i by transfer
      have "A $$ (i, LEAST n. A $$ (i, n)  0) = A' $h ?i' $h (LEAST n. A' $h ?i' $h n  0)"   
        by (rule element_least_not_zero_eq_HMA_JNF[OF AA' ii' ii' zero_i'])
      also have "...  associates" using rhs zero_i' i by simp  
      finally show "A $$ (i, LEAST n. A $$ (i, n)  0)  associates" .
    qed
  qed
  have 3: "(i<dim_row A. ¬ is_zero_row_JNF i A  (j<i. A $$ (j, LEAST n. A $$ (i, n)  0) 
             residues (A $$ (i, LEAST n. A $$ (i, n)  0)))) =
            (i. ¬ is_zero_row i A'  (j<i. A' $h j $h (LEAST n. A' $h i $h n  0)
             residues (A' $h i $h (LEAST n. A' $h i $h n  0))))" (is "?lhs = ?rhs")
  proof 
    assume lhs: "?lhs"
    show "?rhs"
    proof (rule allI, rule impI, rule allI, rule impI)
      fix i' j' :: 'm
      assume zero_i': "¬ is_zero_row i' A'" and j'i': "j' < i'" 
      let ?i = "Mod_Type.to_nat i'"
      have ii'[transfer_rule]: "Mod_Type_Connect.HMA_I ?i i'" unfolding Mod_Type_Connect.HMA_I_def by simp
      have i: "?i < dim_row A"
        using AA' Mod_Type_Connect.dim_row_transfer_rule mod_type_class.to_nat_less_card
        by fastforce
      have zero_i: "¬ is_zero_row_JNF ?i A" using zero_i' by transfer'
      let ?j = "Mod_Type.to_nat j'"
      have jj'[transfer_rule]: "Mod_Type_Connect.HMA_I ?j j'" unfolding Mod_Type_Connect.HMA_I_def by simp
      have ji: "?j<?i" using j'i' to_nat_mono by blast
      have eq1: "A $$ (?j, LEAST n. A $$ (?i, n)  0) = A' $h j' $h (LEAST n. A' $h i' $h n  0)"
        by (rule element_least_not_zero_eq_HMA_JNF[OF AA' jj' ii' zero_i'])
      have eq2: "A $$ (?i, LEAST n. A $$ (?i, n)  0) = A' $h i' $h (LEAST n. A' $h i' $h n  0)"
        by (rule element_least_not_zero_eq_HMA_JNF[OF AA' ii' ii' zero_i'])
      show "A' $h j' $h (LEAST n. A' $h i' $h n  0)  residues (A' $h i' $h (LEAST n. A' $h i' $h n  0))"
        using lhs eq1 eq2 ji i zero_i by fastforce
    qed
  next
    assume rhs: "?rhs"
    show "?lhs"
    proof (safe)
      fix i j assume i: "i < dim_row A" and zero_i: "¬ is_zero_row_JNF i A" and ji: "j < i"
      let ?i' = "Mod_Type.from_nat i :: 'm"
      have ii'[transfer_rule]: "Mod_Type_Connect.HMA_I i ?i'" unfolding Mod_Type_Connect.HMA_I_def
        using Mod_Type.to_nat_from_nat_id AA' Mod_Type_Connect.dim_row_transfer_rule i by fastforce
      have zero_i': "¬ is_zero_row ?i' A'" using zero_i by transfer
      let ?j' = "Mod_Type.from_nat j :: 'm"
      have j'i': "?j' < ?i'" using AA' Mod_Type_Connect.dim_row_transfer_rule from_nat_mono i ji
        by fastforce
      have jj'[transfer_rule]: "Mod_Type_Connect.HMA_I j ?j'" unfolding Mod_Type_Connect.HMA_I_def
        using Mod_Type.to_nat_from_nat_id[of j, where ?'a='m] AA' 
          Mod_Type_Connect.dim_row_transfer_rule[OF AA'] j'i' i ji by auto
      have zero_i': "¬ is_zero_row ?i' A'" using zero_i by transfer
      have eq1: "A $$ (j, LEAST n. A $$ (i, n)  0) = A' $h ?j' $h (LEAST n. A' $h ?i' $h n  0)"
        by (rule element_least_not_zero_eq_HMA_JNF[OF AA' jj' ii' zero_i'])
      have eq2: "A $$ (i, LEAST n. A $$ (i, n)  0) = A' $h ?i' $h (LEAST n. A' $h ?i' $h n  0)"
        by (rule element_least_not_zero_eq_HMA_JNF[OF AA' ii' ii' zero_i'])
      show "A $$ (j, LEAST n. A $$ (i, n)  0)  residues (A $$ (i, LEAST n. A $$ (i, n)  0))"
        using rhs eq1 eq2 j'i' i zero_i' by fastforce
    qed
  qed
  show "Hermite_JNF associates residues A = Hermite associates residues A'"
    unfolding Hermite_def Hermite_JNF_def 
    using 1 2 3 by auto
qed


corollary HMA_Hermite2[transfer_rule]:
  shows "((=) ===> (=) ===> (Mod_Type_Connect.HMA_M :: _ 
   'a :: {bezout_ring_div,normalization_semidom} ^ 'n :: mod_type ^ 'm :: mod_type  _) ===> (=)) 
  (Hermite_JNF) (Hermite)"
  by (simp add: HMA_Hermite rel_funI)


text ‹Once the definitions of both libraries are connected, we start to move the theorem about
the uniqueness of the Hermite normal form (stated in HOL Analysis, named @{text "Hermite_unique"})
to JNF.›


text ‹Using the previous transfer rules, we get an statement in JNF. However, the matrices
have @{text "CARD('n::mod_type)"} rows and columns. We want to get rid of that type variable and
just state that they are of dimension $n \times n$ (expressed via the predicate @{text "carrier_mat"}

lemma Hermite_unique_JNF':
  fixes A::"'a::{bezout_ring_div,normalization_euclidean_semiring,unique_euclidean_ring} mat"
  assumes "A  carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
    "P  carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
    "H  carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
    "Q  carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
    "K  carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
  assumes "A = P * H"
    and "A = Q * K" and "invertible_mat A" and "invertible_mat P" 
    and "invertible_mat Q" and "Hermite_JNF associates res H" and "Hermite_JNF associates res K"
shows "H = K" 
proof -
  define A' where "A' = (Mod_Type_Connect.to_hmam A :: 'a ^'n :: mod_type ^'n :: mod_type)"
  define P' where "P' = (Mod_Type_Connect.to_hmam P :: 'a ^'n :: mod_type ^'n :: mod_type)"
  define H' where "H' = (Mod_Type_Connect.to_hmam H :: 'a ^'n :: mod_type ^'n :: mod_type)"
  define Q' where "Q' = (Mod_Type_Connect.to_hmam Q :: 'a ^'n :: mod_type ^'n :: mod_type)"
  define K' where "K' = (Mod_Type_Connect.to_hmam K :: 'a ^'n :: mod_type ^'n :: mod_type)"
  have AA'[transfer_rule]: "Mod_Type_Connect.HMA_M A A'" unfolding Mod_Type_Connect.HMA_M_def using assms A'_def by auto  
  have PP'[transfer_rule]: "Mod_Type_Connect.HMA_M P P'" unfolding Mod_Type_Connect.HMA_M_def using assms P'_def by auto
  have HH'[transfer_rule]: "Mod_Type_Connect.HMA_M H H'" unfolding Mod_Type_Connect.HMA_M_def using assms H'_def by auto
  have QQ'[transfer_rule]: "Mod_Type_Connect.HMA_M Q Q'" unfolding Mod_Type_Connect.HMA_M_def using assms Q'_def by auto
  have KK'[transfer_rule]: "Mod_Type_Connect.HMA_M K K'" unfolding Mod_Type_Connect.HMA_M_def using assms K'_def by auto
  have A_PH: "A' = P' ** H'" using assms by transfer
  moreover have A_QK: "A' = Q' ** K'" using assms by transfer
  moreover have inv_A: "invertible A'" using assms by transfer
  moreover have inv_P: "invertible P'" using assms by transfer
  moreover have inv_Q: "invertible Q'" using assms by transfer
  moreover have H: "Hermite associates res H'" using assms by transfer
  moreover have K: "Hermite associates res K'" using assms by transfer
  ultimately have "H' = K'" using Hermite_unique by blast
  thus "H=K" by transfer
qed




text ‹Since the @{text "mod_type"} restriction relies on many things, the shortcut is to use 
the @{text "mod_ring"} typedef developed in the Berlekamp-Zassenhaus development. 
This type definition allows us to apply local type definitions easily.
Since @{text "mod_ring"} is just an instance of @{text "mod_type"}, it is straightforward to
obtain the following lemma, where @{text "CARD('n::mod_type)"} has now been substituted by
@{text "CARD('n::nontriv mod_ring)"}

corollary Hermite_unique_JNF_with_nontriv_mod_ring:
  fixes A::"'a::{bezout_ring_div,normalization_euclidean_semiring,unique_euclidean_ring} mat"
  assumes "A  carrier_mat CARD('n) CARD('n::nontriv mod_ring)"
    "P  carrier_mat CARD('n) CARD('n)"
    "H  carrier_mat CARD('n) CARD('n)"
    "Q  carrier_mat CARD('n) CARD('n)"
    "K  carrier_mat CARD('n) CARD('n)"
  assumes "A = P * H"
    and "A = Q * K" and "invertible_mat A" and "invertible_mat P" 
    and "invertible_mat Q" and "Hermite_JNF associates res H" and "Hermite_JNF associates res K"
shows "H = K" using Hermite_unique_JNF' assms by (smt CARD_mod_ring)

text ‹Now, we assume in a context that there exists a type text @{text "'b"} of cardinality $n$
and we prove inside this context the lemma.›

context
  fixes n::nat
  assumes local_typedef: "(Rep :: ('b  int)) Abs. type_definition Rep Abs {0..<n :: int}"
  and p: "n>1"
begin

private lemma type_to_set:
  shows "class.nontriv TYPE('b)" (is ?a) and "n=CARD('b)" (is ?b)
proof -
  from local_typedef obtain Rep::"('b  int)" and Abs 
    where t: "type_definition Rep Abs {0..<n :: int}" by auto
  have "card (UNIV :: 'b set) = card {0..<n}" using t type_definition.card by fastforce
  also have "... = n" by auto
  finally show ?b ..
  then show ?a unfolding class.nontriv_def using p by auto
qed


lemma Hermite_unique_JNF_aux:
  fixes A::"'a::{bezout_ring_div,normalization_euclidean_semiring,unique_euclidean_ring} mat"
  assumes "A  carrier_mat n n"
    "P  carrier_mat n n"
    "H  carrier_mat n n"
    "Q  carrier_mat n n "
    "K  carrier_mat n n"
  assumes "A = P * H"
    and "A = Q * K" and "invertible_mat A" and "invertible_mat P" 
    and "invertible_mat Q" and "Hermite_JNF associates res H" and "Hermite_JNF associates res K"
shows "H = K"
  using Hermite_unique_JNF_with_nontriv_mod_ring[unfolded CARD_mod_ring,
      internalize_sort "'n::nontriv", where ?'a='b]
  unfolding type_to_set(2)[symmetric] using type_to_set(1) assms by blast
end                     

text ‹Now, we cancel the local type definition of the previous context. 
Since the @{text "mod_type"} restriction imposes the type to have cardinality greater than 1, 
the cases $n=0$ and $n=1$ must be proved separately (they are trivial)›

lemma Hermite_unique_JNF:
  fixes A::"'a::{bezout_ring_div,normalization_euclidean_semiring,unique_euclidean_ring} mat"
  assumes A: "A  carrier_mat n n" and P: "P  carrier_mat n n" and H: "H  carrier_mat n n"
   and Q: "Q  carrier_mat n n" and K: "K  carrier_mat n n"
 assumes A_PH: "A = P * H" and A_QK: "A = Q * K"
   and inv_A: "invertible_mat A" and inv_P: "invertible_mat P" and inv_Q: "invertible_mat Q"
   and HNF_H: "Hermite_JNF associates res H" and HNF_K: "Hermite_JNF associates res K"
  shows "H = K"
proof (cases "n=0  n=1")
  case True note zero_or_one = True
  show ?thesis
  proof (cases "n=0")
    case True
    then show ?thesis using assms by auto
  next
    case False
    have CS_A: "Complete_set_non_associates associates" using HNF_H unfolding Hermite_JNF_def by simp
    have H: "H  carrier_mat 1 1" and K: "K carrier_mat 1 1" using False zero_or_one assms by auto
    have det_P_dvd_1: "Determinant.det P dvd 1" using invertible_iff_is_unit_JNF inv_P P by blast
    have det_Q_dvd_1: "Determinant.det Q dvd 1" using invertible_iff_is_unit_JNF inv_Q Q by blast
    have PH_QK: "Determinant.det P * Determinant.det H = Determinant.det Q * Determinant.det K"
      using Determinant.det_mult assms by metis
    hence "Determinant.det P * H $$ (0,0) = Determinant.det Q * K $$ (0,0)"
      by (metis H K determinant_one_element)
    obtain u where uH_K: "u * H $$(0,0) = K $$ (0,0)" and unit_u: "is_unit u"
      by (metis (no_types, hide_lams) H K PH_QK algebraic_semidom_class.dvd_mult_unit_iff det_P_dvd_1 
          det_Q_dvd_1 det_singleton dvdE dvd_mult_cancel_left mult.commute mult.right_neutral one_dvd)
    have H00_not_0: "H $$ (0,0)  0"
      by (metis A A_PH Determinant.det_mult False H P determinant_one_element inv_A
          invertible_iff_is_unit_JNF mult_not_zero not_is_unit_0 zero_or_one)
    hence LEAST_H: "(LEAST n. H $$ (0,n)  0) = 0" by simp
    have H00: "H $$ (0,0)  associates" using HNF_H LEAST_H H H00_not_0 
      unfolding Hermite_JNF_def is_zero_row_JNF_def by auto
    have K00_not_0: "K $$ (0,0)  0"
      by (metis A A_QK Determinant.det_mult False K Q determinant_one_element inv_A
          invertible_iff_is_unit_JNF mult_not_zero not_is_unit_0 zero_or_one)
    hence LEAST_K: "(LEAST n. K $$ (0,n)  0) = 0" by simp
    have K00: "K $$ (0,0)  associates" using HNF_K LEAST_K K K00_not_0 
      unfolding Hermite_JNF_def is_zero_row_JNF_def by auto
    have ass_H00_K00: "normalize (H $$ (0,0)) = normalize (K $$ (0,0))"
      by (metis normalize_mult_unit_left uH_K unit_u)
    have H00_eq_K00: "H $$ (0,0) = K $$ (0,0)" 
      using in_Ass_not_associated[OF CS_A H00 K00] ass_H00_K00 by auto
    show ?thesis by (rule eq_matI, insert H K H00_eq_K00, auto)
  qed
next
  case False
  hence "{0..<int n}  {}" by auto
  moreover have "n>1" using False by simp
  ultimately show ?thesis using Hermite_unique_JNF_aux[cancel_type_definition] assms by metis (*Cancel local type definition*)
qed

end

text ‹From here on, we apply the same approach to move the new generalized statement about
the uniqueness Hermite normal form, i.e., the version restricted to integer matrices, but imposing
invertibility over the rationals.›

(*TODO: move to Mod_Type_Connect in SNF development. 
  There are two definitions of map_matrix, one in HMA_Connect and one in Finite_Cartesian_Product, 
  but they are the same.*)
lemma HMA_map_matrix [transfer_rule]: 
  "((=) ===> Mod_Type_Connect.HMA_M ===> Mod_Type_Connect.HMA_M) map_mat map_matrix"
  unfolding map_vector_def map_matrix_def[abs_def] map_mat_def[abs_def] 
    Mod_Type_Connect.HMA_M_def Mod_Type_Connect.from_hmam_def
  by auto



lemma Hermite_unique_generalized_JNF':
  fixes A::"int mat"
  assumes "A  carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
    "P  carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
    "H  carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
    "Q  carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
    "K  carrier_mat CARD('n::mod_type) CARD('n::mod_type)"
  assumes "A = P * H"
    and "A = Q * K" and "invertible_mat (map_mat rat_of_int A)" and "invertible_mat P" 
    and "invertible_mat Q" and "Hermite_JNF associates res H" and "Hermite_JNF associates res K"
shows "H = K" 
proof -
  define A' where "A' = (Mod_Type_Connect.to_hmam A :: int ^'n :: mod_type ^'n :: mod_type)"
  define P' where "P' = (Mod_Type_Connect.to_hmam P :: int ^'n :: mod_type ^'n :: mod_type)"
  define H' where "H' = (Mod_Type_Connect.to_hmam H :: int ^'n :: mod_type ^'n :: mod_type)"
  define Q' where "Q' = (Mod_Type_Connect.to_hmam Q :: int ^'n :: mod_type ^'n :: mod_type)"
  define K' where "K' = (Mod_Type_Connect.to_hmam K :: int ^'n :: mod_type ^'n :: mod_type)"
  have AA'[transfer_rule]: "Mod_Type_Connect.HMA_M A A'" unfolding Mod_Type_Connect.HMA_M_def using assms A'_def by auto  
  have PP'[transfer_rule]: "Mod_Type_Connect.HMA_M P P'" unfolding Mod_Type_Connect.HMA_M_def using assms P'_def by auto
  have HH'[transfer_rule]: "Mod_Type_Connect.HMA_M H H'" unfolding Mod_Type_Connect.HMA_M_def using assms H'_def by auto
  have QQ'[transfer_rule]: "Mod_Type_Connect.HMA_M Q Q'" unfolding Mod_Type_Connect.HMA_M_def using assms Q'_def by auto
  have KK'[transfer_rule]: "Mod_Type_Connect.HMA_M K K'" unfolding Mod_Type_Connect.HMA_M_def using assms K'_def by auto
  have A_PH: "A' = P' ** H'" using assms by transfer
  moreover have A_QK: "A' = Q' ** K'" using assms by transfer
  moreover have inv_A: "invertible (map_matrix rat_of_int A')" using assms by transfer
  moreover have "invertible (Finite_Cartesian_Product.map_matrix rat_of_int A')"
    using inv_A unfolding Finite_Cartesian_Product.map_matrix_def map_matrix_def map_vector_def
    by simp
  moreover have inv_P: "invertible P'" using assms by transfer
  moreover have inv_Q: "invertible Q'" using assms by transfer
  moreover have H: "Hermite associates res H'" using assms by transfer
  moreover have K: "Hermite associates res K'" using assms by transfer
  ultimately have "H' = K'" using Hermite_unique_generalized by blast
  thus "H=K" by transfer
qed


corollary Hermite_unique_generalized_JNF_with_nontriv_mod_ring:
  fixes A::"int mat"
  assumes "A  carrier_mat CARD('n) CARD('n::nontriv mod_ring)"
    "P  carrier_mat CARD('n) CARD('n)"
    "H  carrier_mat CARD('n) CARD('n)"
    "Q  carrier_mat CARD('n) CARD('n)"
    "K  carrier_mat CARD('n) CARD('n)"
  assumes "A = P * H"
    and "A = Q * K" and "invertible_mat (map_mat rat_of_int A)" and "invertible_mat P" 
    and "invertible_mat Q" and "Hermite_JNF associates res H" and "Hermite_JNF associates res K"
shows "H = K" using Hermite_unique_generalized_JNF' assms by (smt CARD_mod_ring)




context
  fixes p::nat
  assumes local_typedef: "(Rep :: ('b  int)) Abs. type_definition Rep Abs {0..<p :: int}"
  and p: "p>1"
begin

private lemma type_to_set2:
  shows "class.nontriv TYPE('b)" (is ?a) and "p=CARD('b)" (is ?b)
proof -
  from local_typedef obtain Rep::"('b  int)" and Abs 
    where t: "type_definition Rep Abs {0..<p :: int}" by auto
  have "card (UNIV :: 'b set) = card {0..<p}" using t type_definition.card by fastforce
  also have "... = p" by auto
  finally show ?b ..
  then show ?a unfolding class.nontriv_def using p by auto
qed


lemma Hermite_unique_generalized_JNF_aux:
  fixes A::"int mat"
  assumes "A  carrier_mat p p"
    "P  carrier_mat p p"
    "H  carrier_mat p p"
    "Q  carrier_mat p p"
    "K  carrier_mat p p"
  assumes "A = P * H"
    and "A = Q * K" and "invertible_mat (map_mat rat_of_int A)" and "invertible_mat P" 
    and "invertible_mat Q" and "Hermite_JNF associates res H" and "Hermite_JNF associates res K"
shows "H = K"
  using Hermite_unique_generalized_JNF_with_nontriv_mod_ring[unfolded CARD_mod_ring,
      internalize_sort "'n::nontriv", where ?'a='b]
  unfolding type_to_set2(2)[symmetric] using type_to_set2(1) assms by blast
end                     


lemma HNF_unique_generalized_JNF:
  fixes A::"int mat"
  assumes A: "A  carrier_mat n n" and P: "P  carrier_mat n n" and H: "H  carrier_mat n n"
   and Q: "Q  carrier_mat n n" and K: "K  carrier_mat n n"
 assumes A_PH: "A = P * H" and A_QK: "A = Q * K"
   and inv_A: "invertible_mat (map_mat rat_of_int A)" and inv_P: "invertible_mat P" and inv_Q: "invertible_mat Q"
   and HNF_H: "Hermite_JNF associates res H" and HNF_K: "Hermite_JNF associates res K"
  shows "H = K"
proof (cases "n=0  n=1")
  case True note zero_or_one = True
  show ?thesis
  proof (cases "n=0")
    case True
    then show ?thesis using assms by auto
  next
    let ?RAT = "map_mat rat_of_int"
    case False
    hence n: "n=1" using zero_or_one by auto
    have CS_A: "Complete_set_non_associates associates" using HNF_H unfolding Hermite_JNF_def by simp
    have H: "H  carrier_mat 1 1" and K: "K carrier_mat 1 1" using False zero_or_one assms by auto
    have det_P_dvd_1: "Determinant.det P dvd 1" using invertible_iff_is_unit_JNF inv_P P by blast
    have det_Q_dvd_1: "Determinant.det Q dvd 1" using invertible_iff_is_unit_JNF inv_Q Q by blast
    have PH_QK: "Determinant.det P * Determinant.det H = Determinant.det Q * Determinant.det K"
      using Determinant.det_mult assms by metis
    hence "Determinant.det P * H $$ (0,0) = Determinant.det Q * K $$ (0,0)"
      by (metis H K determinant_one_element)
    obtain u where uH_K: "u * H $$(0,0) = K $$ (0,0)" and unit_u: "is_unit u"
      by (metis (no_types, hide_lams) H K PH_QK algebraic_semidom_class.dvd_mult_unit_iff det_P_dvd_1 
          det_Q_dvd_1 det_singleton dvdE dvd_mult_cancel_left mult.commute mult.right_neutral one_dvd)
    have H00_not_0: "H $$ (0,0)  0"
    proof -      
      have "?RAT A = ?RAT P * ?RAT H" using A_PH
        using P H n of_int_hom.mat_hom_mult by blast
      hence "det (?RAT H)  0" 
        by (metis A Determinant.det_mult False H P inv_A invertible_iff_is_unit_JNF 
            map_carrier_mat mult_eq_0_iff not_is_unit_0 zero_or_one)
      thus ?thesis
        using H determinant_one_element by force      
    qed
    hence LEAST_H: "(LEAST n. H $$ (0,n)  0) = 0" by simp
    have H00: "H $$ (0,0)  associates" using HNF_H LEAST_H H H00_not_0 
      unfolding Hermite_JNF_def is_zero_row_JNF_def by auto
    have K00_not_0: "K $$ (0,0)  0"
    proof -
      have "?RAT A = ?RAT Q * ?RAT K" using A_QK
        using Q K n of_int_hom.mat_hom_mult by blast
      hence "det (?RAT K)  0" 
        by (metis A Determinant.det_mult False Q K inv_A invertible_iff_is_unit_JNF 
            map_carrier_mat mult_eq_0_iff not_is_unit_0 zero_or_one)
      thus ?thesis
        using K determinant_one_element by force
    qed
    hence LEAST_K: "(LEAST n. K $$ (0,n)  0) = 0" by simp
    have K00: "K $$ (0,0)  associates" using HNF_K LEAST_K K K00_not_0 
      unfolding Hermite_JNF_def is_zero_row_JNF_def by auto
    have ass_H00_K00: "normalize (H $$ (0,0)) = normalize (K $$ (0,0))"
      by (metis normalize_mult_unit_left uH_K unit_u)
    have H00_eq_K00: "H $$ (0,0) = K $$ (0,0)" 
      using in_Ass_not_associated[OF CS_A H00 K00] ass_H00_K00 by auto
    show ?thesis by (rule eq_matI, insert H K H00_eq_K00, auto)
  qed
next
  case False
  hence "{0..<int n}  {}" by auto
  moreover have "n>1" using False by simp
  ultimately show ?thesis 
    using Hermite_unique_generalized_JNF_aux[cancel_type_definition] assms by metis (*Cancel local type definition*)
qed 

end

Theory HNF_Mod_Det_Algorithm

section ‹Formalization of an efficient Hermite normal form algorithm›

text ‹We formalize a version of the Hermite normal form algorithm based on reductions modulo
the determinant. This avoids the growth of the intermediate coefficients.›

subsection ‹Implementation of the algorithm using generic modulo operation›

text ‹Exception on generic modulo: currently in Hermite-reduce-above, ordinary div/mod is used,
  since that is our choice for the complete set of residues.›

theory HNF_Mod_Det_Algorithm
  imports
    Jordan_Normal_Form.Gauss_Jordan_IArray_Impl
    Show.Show_Instances
    Jordan_Normal_Form.Determinant_Impl
    Jordan_Normal_Form.Show_Matrix
    LLL_Basis_Reduction.LLL_Certification   
    Smith_Normal_Form.SNF_Algorithm_Euclidean_Domain
    Smith_Normal_Form.SNF_Missing_Lemmas
    Uniqueness_Hermite_JNF
    Matrix_Change_Row
begin

subsubsection ‹Echelon form algorithm›

fun make_first_column_positive :: "int mat  int mat" where
  "make_first_column_positive A = (
       Matrix.mat (dim_row A) (dim_col A) ― ‹ Create a matrix of the same dimensions ›
          (λ(i,j). if A $$(i,0) < 0 then - A $$(i,j) else A $$(i,j)
            )
  )"


locale mod_operation =
  fixes generic_mod :: "int  int  int" (infixl "gmod" 70)
    and generic_div :: "int  int  int" (infixl "gdiv" 70)
begin

text ‹Version for reducing all elements›

fun reduce :: "nat  nat  int  int mat  int mat" where
  "reduce a b D A = (let Aaj = A$$(a,0); Abj = A $$ (b,0)     
  in
  if Aaj = 0 then A else
  case euclid_ext2 Aaj Abj of (p,q,u,v,d)  ― ‹ p*Aaj + q * Abj = d, u = - Abj/d, v = Aaj/d ›
       Matrix.mat (dim_row A) (dim_col A) ― ‹ Create a matrix of the same dimensions ›
          (λ(i,k). if i = a then let r = (p*A$$(a,k) + q*A$$(b,k)) in
                              if k = 0 then if D dvd r then D else r else r gmod D ― ‹ Row a is multiplied by p and added row b multiplied by q, modulo D›
                   else if i = b then let r = u * A$$(a,k) + v * A$$(b,k) in
                               if k = 0 then r else r gmod D ― ‹ Row b is multiplied by v and added row a multiplied by u, modulo D›
                   else A$$(i,k)  ― ‹ All the other rows remain unchanged›
            )
  )"

text ‹Version for reducing, with abs-checking›

fun reduce_abs :: "nat  nat  int  int mat  int mat" where
  "reduce_abs a b D A = (let Aaj = A$$(a,0); Abj = A $$ (b,0)     
  in
  if Aaj = 0 then A else
  case euclid_ext2 Aaj Abj of (p,q,u,v,d)  ― ‹ p*Aaj + q * Abj = d, u = - Abj/d, v = Aaj/d ›
       Matrix.mat (dim_row A) (dim_col A) ― ‹ Create a matrix of the same dimensions ›
          (λ(i,k). if i = a then let r = (p*A$$(a,k) + q*A$$(b,k)) in
                            if abs r > D then if k = 0  D dvd r then D else r gmod D else r 
                   else if i = b then let r = u * A$$(a,k) + v * A$$(b,k) in
                              if abs r > D then r gmod D else r
                   else A$$(i,k)  ― ‹ All the other rows remain unchanged›
            )
  )"

definition reduce_impl :: "nat  nat  int  int mat  int mat" where
  "reduce_impl a b D A = (let 
    row_a = Matrix.row A a; 
    Aaj = row_a $v 0     
  in
  if Aaj = 0 then A else let 
    row_b = Matrix.row A b;
    Abj = row_b $v 0 in
  case euclid_ext2 Aaj Abj of (p,q,u,v,d)  
    let row_a' = (λ k ak. let r = (p * ak + q * row_b $v k) in
              if k = 0 then if D dvd r then D else r else r gmod D);
        row_b' = (λ k bk. let r = u * row_a $v k + v * bk in
                               if k = 0 then r else r gmod D)
     in change_row a row_a' (change_row b row_b' A)
  )"

definition reduce_abs_impl :: "nat  nat  int  int mat  int mat" where
  "reduce_abs_impl a b D A = (let 
    row_a = Matrix.row A a; 
    Aaj = row_a $v 0     
  in
  if Aaj = 0 then A else let 
    row_b = Matrix.row A b;
    Abj = row_b $v 0 in
  case euclid_ext2 Aaj Abj of (p,q,u,v,d)  
    let row_a' = (λ k ak. let r = (p * ak + q * row_b $v k) in
              if abs r > D then if k = 0  D dvd r then D else r gmod D else r);
        row_b' = (λ k bk. let r = u * row_a $v k + v * bk in
                                if abs r > D then r gmod D else r)
     in change_row a row_a' (change_row b row_b' A)
  )"

lemma reduce_impl: "a < nr  b < nr  0 < nc  a  b  A  carrier_mat nr nc
   reduce_impl a b D A = reduce a b D A" 
  unfolding reduce_impl_def reduce.simps Let_def
  apply (intro if_cong[OF _ refl], force)
  apply (intro prod.case_cong refl, force)
  apply (intro eq_matI, auto)
  done


lemma reduce_abs_impl: "a < nr  b < nr  0 < nc  a  b  A  carrier_mat nr nc
   reduce_abs_impl a b D A = reduce_abs a b D A" 
  unfolding reduce_abs_impl_def reduce_abs.simps Let_def
  apply (intro if_cong[OF _ refl], force)
  apply (intro prod.case_cong refl, force)
  apply (intro eq_matI, auto)
  done
  

(* This functions reduce the elements below the position (a,0), given a list of positions 
   of non-zero positions as input*)
fun reduce_below :: "nat  nat list  int  int mat  int mat"
where "reduce_below a [] D A = A"
  | "reduce_below a (x # xs) D A = reduce_below a xs D (reduce a x D A)"

fun reduce_below_impl :: "nat  nat list  int  int mat  int mat"
where "reduce_below_impl a [] D A = A"
  | "reduce_below_impl a (x # xs) D A = reduce_below_impl a xs D (reduce_impl a x D A)"

lemma reduce_impl_carrier[simp,intro]: "A  carrier_mat m n  reduce_impl a b D A  carrier_mat m n" 
  unfolding reduce_impl_def Let_def by (auto split: prod.splits)

lemma reduce_below_impl: "a < nr  0 < nc  ( b. b  set bs  b < nr)  a  set bs 
   A  carrier_mat nr nc  reduce_below_impl a bs D A = reduce_below a bs D A" 
proof (induct bs arbitrary: A)
  case (Cons b bs A)
  show ?case by (simp del: reduce.simps, 
      subst reduce_impl[of _ nr _ nc], 
      (insert Cons, auto simp del: reduce.simps)[5],
      rule Cons(1), insert Cons(2-), auto simp: Let_def split: prod.splits)
qed simp



fun reduce_below_abs :: "nat  nat list  int  int mat  int mat"
where "reduce_below_abs a [] D A = A"
  | "reduce_below_abs a (x # xs) D A = reduce_below_abs a xs D (reduce_abs a x D A)"

fun reduce_below_abs_impl :: "nat  nat list  int  int mat  int mat"
where "reduce_below_abs_impl a [] D A = A"
  | "reduce_below_abs_impl a (x # xs) D A = reduce_below_abs_impl a xs D (reduce_abs_impl a x D A)"

lemma reduce_abs_impl_carrier[simp,intro]: "A  carrier_mat m n  reduce_abs_impl a b D A  carrier_mat m n" 
  unfolding reduce_abs_impl_def Let_def by (auto split: prod.splits)

lemma reduce_abs_below_impl: "a < nr  0 < nc  ( b. b  set bs  b < nr)  a  set bs 
   A  carrier_mat nr nc  reduce_below_abs_impl a bs D A = reduce_below_abs a bs D A" 
proof (induct bs arbitrary: A)
  case (Cons b bs A)
  show ?case by (simp del: reduce_abs.simps, 
      subst reduce_abs_impl[of _ nr _ nc], 
      (insert Cons, auto simp del: reduce_abs.simps)[5],
      rule Cons(1), insert Cons(2-), auto simp: Let_def split: prod.splits)
qed simp

text ‹This function outputs a matrix in echelon form via reductions modulo the determinant›


function FindPreHNF :: "bool  int  int mat  int mat"
  where "FindPreHNF abs_flag D A = 
  (let m = dim_row A; n = dim_col A in 
  if m < 2  n = 0 then A else ― ‹ No operations are carried out if m = 1 ›
  let non_zero_positions = filter (λi. A $$ (i,0)  0) [1..<dim_row A];
         A' = (if A$$(0,0)  0 then A
              else let i = non_zero_positions ! 0  ― ‹ Select the first non-zero position below the first element›
                   in swaprows 0 i A  
              );
        Reduce = (if abs_flag then reduce_below_abs else reduce_below)
    in
      if n < 2 then Reduce 0 non_zero_positions D A'  ― ‹ If n = 1, then we have to reduce the column ›   
    else 
      let         
        (A_UL,A_UR,A_DL,A_DR) = split_block (Reduce 0 non_zero_positions D (make_first_column_positive A')) 1 1; 
        sub_PreHNF = FindPreHNF abs_flag D A_DR in       
        four_block_mat A_UL A_UR A_DL sub_PreHNF)"                 
  by pat_completeness auto 

termination
proof (relation "Wellfounded.measure (λ(abs_flag,D,A). dim_col A)")
  show "wf (Wellfounded.measure (λ(abs_flag,D, A). dim_col A))" by auto
  fix abs_flag D A m n nz A' R xd A'_UL y A'_UR ya A'_DL A'_DR
  assume m: "m = dim_row A" and n:"n = dim_col A"
    and m2: "¬ (m < 2  n = 0)" and nz_def: "nz = filter (λi. A $$ (i, 0)  0) [1..<dim_row A] "
    and A'_def: "A' = (if A $$ (0, 0)  0 then A else let i = nz ! 0 in swaprows 0 i A)"
    and R_def: "R = (if abs_flag then reduce_below_abs else reduce_below)"
    and n2: "¬ n < 2" and "xd = split_block (R 0 nz D (make_first_column_positive A')) 1 1"
    and "(A'_UL, y) = xd" and "(A'_UR, ya) = y" and "(A'_DL, A'_DR) = ya" 
  hence A'_split: "(A'_UL, A'_UR, A'_DL, A'_DR) 
        = split_block (R 0 nz D (make_first_column_positive A')) 1 1" by force
  have dr_mk1: "dim_row (make_first_column_positive A) = dim_row A" for A by auto
  have dr_mk2: "dim_col (make_first_column_positive A) = dim_col A" for A by auto  
  have r1: "reduce_below a xs D A  carrier_mat m n" if "A  carrier_mat m n" for A a xs
    using that by (induct a xs D A rule: reduce_below.induct, auto simp add: Let_def euclid_ext2_def) 
  hence R: "(reduce_below 0 nz D (make_first_column_positive A'))  carrier_mat m n"
    using A'_def m n 
    by (metis carrier_matI index_mat_swaprows(2,3) dr_mk1 dr_mk2)
  have "reduce_below_abs a xs D A  carrier_mat m n" if "A  carrier_mat m n" for A a xs
    using that by (induct a xs D A rule: reduce_below_abs.induct, auto simp add: Let_def euclid_ext2_def) 
  hence R2: "(reduce_below_abs 0 nz D (make_first_column_positive A'))  carrier_mat m n"
    using A'_def m n 
    by (metis carrier_matI index_mat_swaprows(2,3) dr_mk1 dr_mk2)
 
  have "A'_DR  carrier_mat (m-1) (n-1)"
    by (cases abs_flag; rule split_block(4)[OF A'_split[symmetric]],insert m2 n2 m n R_def R R2, auto)
  thus "((abs_flag, D, A'_DR),abs_flag, D, A)  Wellfounded.measure (λ(abs_flag,D, A). dim_col A)" using n2 m2 n m by auto
qed

lemma FindPreHNF_code: "FindPreHNF abs_flag D A = 
  (let m = dim_row A; n = dim_col A in 
  if m < 2  n = 0 then A else 
  let non_zero_positions = filter (λi. A $$ (i,0)  0) [1..<dim_row A];
         A' = (if A$$(0,0)  0 then A
              else let i = non_zero_positions ! 0 in swaprows 0 i A  
              );
         Reduce_impl = (if abs_flag then reduce_below_abs_impl else reduce_below_impl)
    in
      if n < 2 then Reduce_impl 0 non_zero_positions D A'   
    else 
      let         
        (A_UL,A_UR,A_DL,A_DR) = split_block (Reduce_impl 0 non_zero_positions D (make_first_column_positive A')) 1 1; 
        sub_PreHNF = FindPreHNF abs_flag D A_DR in       
        four_block_mat A_UL A_UR A_DL sub_PreHNF)"  (is "?lhs = ?rhs")
proof -
  let ?f = "λR. (if dim_row A < 2  dim_col A = 0 then A else if dim_col A < 2
          then R 0 (filter (λi. A $$ (i, 0)  0) [1..<dim_row A]) D
  (if A $$ (0, 0)  0 then A else swaprows 0 (filter (λi. A $$ (i, 0)  0) [1..<dim_row A] ! 0) A)
  else case split_block (R 0 (filter (λi. A $$ (i, 0)  0) [1..<dim_row A]) D
    (make_first_column_positive (if A $$ (0, 0)  0 then A else 
      swaprows 0 (filter (λi. A $$ (i, 0)  0) [1..<dim_row A] ! 0) A))) 1 1 of
  (A_UL, A_UR, A_DL, A_DR)  four_block_mat A_UL A_UR A_DL (FindPreHNF abs_flag D A_DR))"
  have M_carrier: "make_first_column_positive (if A $$ (0, 0)  0 then A 
    else swaprows 0 (filter (λi. A $$ (i, 0)  0) [1..<dim_row A] ! 0) A) 
     carrier_mat (dim_row A) (dim_col A)"
    by (smt (z3) index_mat_swaprows(2) index_mat_swaprows(3) make_first_column_positive.simps mat_carrier)
  have *: "0  set (filter (λi. A $$ (i, 0)  0) [1..<dim_row A])" by simp
  have "?lhs = ?f (if abs_flag then reduce_below_abs else reduce_below)"
    unfolding FindPreHNF.simps[of abs_flag D A] Let_def by presburger
  also have "... = ?rhs"
  proof (cases abs_flag)
    case True
    have "?f (if abs_flag then reduce_below_abs else reduce_below) = ?f reduce_below_abs" 
      using True by presburger
    also have "... = ?f reduce_below_abs_impl" 
      by ((intro if_cong refl prod.case_cong arg_cong[of _ _ "λ x. split_block x 1 1"];
       (subst reduce_abs_below_impl[where nr = "dim_row A" and nc = "dim_col A"])), (auto)[9])
       (insert M_carrier *, blast+)
    also have "... = ?f (if abs_flag then reduce_below_abs_impl else reduce_below_impl)" 
      using True by presburger
    finally show ?thesis using True unfolding FindPreHNF.simps[of abs_flag D A] Let_def by blast
  next
    case False
    have "?f (if abs_flag then reduce_below_abs else reduce_below) = ?f reduce_below" 
      using False by presburger
    also have "... = ?f reduce_below_impl" 
      by ((intro if_cong refl prod.case_cong arg_cong[of _ _ "λ x. split_block x 1 1"];
       (subst reduce_below_impl[where nr = "dim_row A" and nc = "dim_col A"])), (auto)[9])
       (insert M_carrier *, blast+)
    also have "... = ?f (if abs_flag then reduce_below_abs_impl else reduce_below_impl)" 
      using False by presburger
    finally show ?thesis using False unfolding FindPreHNF.simps[of abs_flag D A] Let_def by blast
  qed
  finally show ?thesis by blast
qed
end

declare mod_operation.FindPreHNF_code[code]
declare mod_operation.reduce_below_impl.simps[code]
declare mod_operation.reduce_impl_def[code]
declare mod_operation.reduce_below_abs_impl.simps[code]
declare mod_operation.reduce_abs_impl_def[code]

subsubsection ‹From echelon form to Hermite normal form›

text ‹From here on, we define functions to transform a matrix in echelon form into its Hermite
normal form. Essentially, we are defining the functions that are available in the AFP entry Hermite
(which uses HOL Analysis + mod-type) in the JNF matrix representation.›

(*Find the first nonzero element of row l (A is upper triangular)*)
definition find_fst_non0_in_row :: "nat  int mat  nat option" where
  "find_fst_non0_in_row l A = (let is = [l ..< dim_col A];
    Ais = filter (λj. A $$ (l, j)  0) is
    in case Ais of []  None | _  Some (Ais!0))"

primrec Hermite_reduce_above
where "Hermite_reduce_above (A::int mat) 0 i j = A"
    | "Hermite_reduce_above A (Suc n) i j = (let
    Aij = A $$ (i,j);
    Anj = A $$ (n,j)
    in 
    Hermite_reduce_above (addrow (- (Anj div Aij)) n i A) n i j)"

definition Hermite_of_row_i :: "int mat  nat  int mat" 
  where "Hermite_of_row_i A i = (
  case find_fst_non0_in_row i A of None  A | Some j  
    let Aij = A $$(i,j) in
    if Aij < 0 then Hermite_reduce_above (multrow i (-1) A) i i j
    else Hermite_reduce_above A i i j)"


primrec Hermite_of_list_of_rows 
  where
 "Hermite_of_list_of_rows A [] = A" | 
 "Hermite_of_list_of_rows A (a#xs) = Hermite_of_list_of_rows (Hermite_of_row_i A a) xs"

text ‹We combine the previous functions to assemble the algorithm›

definition (in mod_operation) "Hermite_mod_det abs_flag A = 
  (let m = dim_row A; n = dim_col A; 
   D = abs(det_int A); 
   A' = A @r D m 1m n;
   E = FindPreHNF abs_flag D A';
   H = Hermite_of_list_of_rows E [0..<m+n]
  in mat_of_rows n (map (Matrix.row H) [0..<m]))"

subsubsection ‹Some examples of execution›

declare mod_operation.Hermite_mod_det_def[code]

value "let B = mat_of_rows_list 4 ([[0,3,1,4],[7,1,0,0],[8,0,19,16],[2,0,0,3::int]]) in
  show (mod_operation.Hermite_mod_det (mod) True B)"

(*
sage: import sage.matrix.matrix_integer_dense_hnf as matrix_integer_dense_hnf
sage: A = matrix(ZZ, [[0,3,1,4],[7,1,0,0],[8,0,19,16],[2,0,0,3]])
sage: A
[ 0  3  1  4]
[ 7  1  0  0]
[ 8  0 19 16]
[ 2  0  0  3]
sage:  H, U = matrix_integer_dense_hnf.hnf_with_transformation(A); H
[   1    0    0  672]
[   0    1    0  660]
[   0    0    1  706]
[   0    0    0 1341]
sage: 
*)


value "let B = mat_of_rows_list 7 ([
[  1,  17, -41,  -1,   1,   0,  0],
[  0,  -1,   2,   0,  -6,   2,   1],
[  9,   2,   1,   1,  -2,   2,  -5],
[ -1,  -3,  -1,   0,  -9,   0,   0],
[  9,  -1,  -9,   0,   0,   0,   1],
[  1,  -1,   1,   0,   1,  -8,   0],
[  1,  -1,   0,  -2,  -1,  -1,   0::int]]) in 
  show (mod_operation.Hermite_mod_det (mod) True B)"

(*
sage: import sage.matrix.matrix_integer_dense_hnf as matrix_integer_dense_hnf
sage: A = random_matrix(ZZ,7,7); A
[  1  17 -41  -1   1   0   0]
[  0  -1   2   0  -6   2   1]
[  9   2   1   1  -2   2  -5]
[ -1  -3  -1   0  -9   0   0]
[  9  -1  -9   0   0   0   1]
[  1  -1   1   0   1  -8   0]
[  1  -1   0  -2  -1  -1   0]
sage: H, U = matrix_integer_dense_hnf.hnf_with_transformation(A); H
[     1      0      0      0      0      1 191934]
[     0      1      0      0      0      0 435767]
[     0      0      1      0      0      1 331950]
[     0      0      0      1      0      0 185641]
[     0      0      0      0      1      0  38022]
[     0      0      0      0      0      2 477471]
[     0      0      0      0      0      0 565304]
*)

end

Theory HNF_Mod_Det_Soundness

subsection ‹Soundness of the algorithm›

theory HNF_Mod_Det_Soundness
  imports
    HNF_Mod_Det_Algorithm
    Signed_Modulo
begin

hide_const(open) Determinants.det Determinants2.upper_triangular
  Finite_Cartesian_Product.row Finite_Cartesian_Product.rows
  Finite_Cartesian_Product.vec

subsubsection ‹Results connecting lattices and Hermite normal form›

text ‹The following results will also be useful for proving the soundness of the certification 
approach.›

lemma of_int_mat_hom_int_id[simp]:
  fixes A::"int mat"
  shows "of_int_hom.mat_hom A = A" unfolding map_mat_def by auto


definition "is_sound_HNF algorithm associates res 
    = (A. let (P,H) = algorithm A; m = dim_row A; n = dim_col A in 
        P  carrier_mat m m  H  carrier_mat m n  invertible_mat P  A = P * H 
         Hermite_JNF associates res H)"

lemma HNF_A_eq_HNF_PA:
  fixes A::"'a::{bezout_ring_div,normalization_euclidean_semiring,unique_euclidean_ring} mat"
  assumes A: "A  carrier_mat n n" and inv_A: "invertible_mat A" 
    and inv_P: "invertible_mat P" and P: "P  carrier_mat n n"
    and sound_HNF: "is_sound_HNF HNF associates res"
    and P1_H1: "(P1,H1) = HNF (P*A)"
    and P2_H2: "(P2,H2) = HNF A"
  shows "H1 = H2"
proof -
  obtain inv_P where P_inv_P: "inverts_mat P inv_P" and inv_P_P: "inverts_mat inv_P P"
    and inv_P: "inv_P  carrier_mat n n"
    using P inv_P obtain_inverse_matrix by blast
  have P1: "P1  carrier_mat n n"
      using P1_H1 sound_HNF unfolding is_sound_HNF_def Let_def
      by (metis (no_types, lifting) P carrier_matD(1) index_mult_mat(2) old.prod.case)
    have H1: "H1  carrier_mat n n" using P1_H1 sound_HNF unfolding is_sound_HNF_def Let_def
  by (metis (no_types, lifting) A P carrier_matD(1) carrier_matD(2) case_prodD index_mult_mat(2,3))
  have invertible_inv_P: "invertible_mat inv_P"
      using P_inv_P inv_P inv_P_P invertible_mat_def square_mat.simps by blast
  have P_A_P1_H1: "P * A = P1 * H1" using P1_H1 sound_HNF unfolding is_sound_HNF_def Let_def
    by (metis (mono_tags, lifting) case_prod_conv)
  hence "A = inv_P * (P1 * H1)"
    by (smt A P inv_P_P inv_P assoc_mult_mat carrier_matD(1) inverts_mat_def left_mult_one_mat)
  hence A_inv_P_P1_H1: "A = (inv_P * P1) * H1"
    by (smt P P1_H1 assoc_mult_mat carrier_matD(1) fst_conv index_mult_mat(2) inv_P 
        is_sound_HNF_def prod.sel(2) sound_HNF split_beta)
  have A_P2_H2: "A = P2 * H2" using P2_H2 sound_HNF unfolding is_sound_HNF_def Let_def
    by (metis (mono_tags, lifting) case_prod_conv)
  have invertible_inv_P_P1: "invertible_mat (inv_P * P1)"
  proof (rule invertible_mult_JNF[OF inv_P P1 invertible_inv_P])   
    show "invertible_mat P1"
      by (smt P1_H1 is_sound_HNF_def prod.sel(1) sound_HNF split_beta)
  qed
  show ?thesis
  proof (rule Hermite_unique_JNF[OF A _ H1 _ _ A_inv_P_P1_H1 A_P2_H2 inv_A invertible_inv_P_P1])
    show "inv_P * P1  carrier_mat n n"
      by (metis carrier_matD(1) carrier_matI index_mult_mat(2) inv_P
          invertible_inv_P_P1 invertible_mat_def square_mat.simps)
    show "P2  carrier_mat n n" 
      by (smt A P2_H2 carrier_matD(1) is_sound_HNF_def prod.sel(1) sound_HNF split_beta)
    show "H2  carrier_mat n n"
      by (smt A P2_H2 carrier_matD(1) carrier_matD(2) is_sound_HNF_def prod.sel(2) sound_HNF split_beta)
    show "invertible_mat P2"
      by (smt P2_H2 is_sound_HNF_def prod.sel(1) sound_HNF split_beta)
    show "Hermite_JNF associates res H1" 
      by (smt P1_H1 is_sound_HNF_def prod.sel(2) sound_HNF split_beta)
    show "Hermite_JNF associates res H2"
      by (smt P2_H2 is_sound_HNF_def prod.sel(2) sound_HNF split_beta)
  qed
qed


context vec_module
begin

lemma mat_mult_invertible_lattice_eq: 
  assumes fs: "set fs  carrier_vec n"
  and gs: "set gs  carrier_vec n"  
  and P: "P  carrier_mat m m" and invertible_P: "invertible_mat P"
  and length_fs: "length fs = m" and length_gs: "length gs = m"
  and prod: "mat_of_rows n fs = (map_mat of_int P) * mat_of_rows n gs" 
  shows "lattice_of fs = lattice_of gs" 
proof thm mat_mult_sub_lattice
  show "lattice_of fs  lattice_of gs"
    by (rule mat_mult_sub_lattice[OF fs gs _ prod],simp add: length_fs length_gs P)
next
  obtain inv_P where P_inv_P: "inverts_mat P inv_P" and inv_P_P: "inverts_mat inv_P P"
    and inv_P: "inv_P  carrier_mat m m"
    using P invertible_P obtain_inverse_matrix by blast
  have "of_int_hom.mat_hom (inv_P) * mat_of_rows n fs 
      = of_int_hom.mat_hom (inv_P) * ((map_mat of_int P) * mat_of_rows n gs)" 
    using prod by auto
  also have "... = of_int_hom.mat_hom (inv_P) * (map_mat of_int P) * mat_of_rows n gs"
    by (smt P assoc_mult_mat inv_P length_gs map_carrier_mat mat_of_rows_carrier(1))
  also have "... = of_int_hom.mat_hom (inv_P * P) * mat_of_rows n gs"
    by (metis P inv_P of_int_hom.mat_hom_mult)
  also have "... = mat_of_rows n gs"
    by (metis carrier_matD(1) inv_P inv_P_P inverts_mat_def left_mult_one_mat' 
        length_gs mat_of_rows_carrier(2) of_int_hom.mat_hom_one)    
  finally have prod: "mat_of_rows n gs = of_int_hom.mat_hom (inv_P) * mat_of_rows n fs" ..
  show "lattice_of gs  lattice_of fs"
    by (rule mat_mult_sub_lattice[OF gs fs _ prod], simp add: length_fs length_gs inv_P)
qed                     

end


context
  fixes n :: nat
begin

interpretation vec_module "TYPE(int)" .

lemma lattice_of_HNF:
  assumes sound_HNF: "is_sound_HNF HNF associates res"
    and P1_H1: "(P,H) = HNF (mat_of_rows n fs)"
    and fs: "set fs  carrier_vec n" and len: "length fs = m"
  shows "lattice_of fs = lattice_of (rows H)"
proof (rule mat_mult_invertible_lattice_eq[OF fs])
  have H: "H  carrier_mat m n" using sound_HNF P1_H1 unfolding is_sound_HNF_def Let_def
    by (metis (mono_tags, lifting) assms(4) mat_of_rows_carrier(2) mat_of_rows_carrier(3) prod.sel(2) split_beta)
  have H_rw: "mat_of_rows n (Matrix.rows H) = H" using mat_of_rows_rows H by fast
  have PH_fs_init: "mat_of_rows n fs = P * H" using sound_HNF P1_H1 unfolding is_sound_HNF_def Let_def
    by (metis (mono_tags, lifting) case_prodD)
  show "mat_of_rows n fs = of_int_hom.mat_hom P * mat_of_rows n (Matrix.rows H)"
    unfolding H_rw of_int_mat_hom_int_id using PH_fs_init by simp  
  show "set (Matrix.rows H)  carrier_vec n" using H rows_carrier by blast
  show "P  carrier_mat m m" using sound_HNF P1_H1 unfolding is_sound_HNF_def Let_def
    by (metis (no_types, lifting) len case_prodD mat_of_rows_carrier(2))    
  show "invertible_mat P" using sound_HNF P1_H1 unfolding is_sound_HNF_def Let_def
    by (metis (no_types, lifting) case_prodD)
  show "length fs = m" using len by simp
  show "length (Matrix.rows H) = m" using H by auto
qed
end


context LLL_with_assms 
begin            

(*For this proof, it seems that is not necessary fs_init to be a list of independent vectors. 
The context assumes it, though.*)
lemma certification_via_eq_HNF:
  assumes sound_HNF: "is_sound_HNF HNF associates res"
    and P1_H1: "(P1,H1) = HNF (mat_of_rows n fs_init)"
    and P2_H2: "(P2,H2) = HNF (mat_of_rows n gs)"
    and H1_H2: "H1 = H2" (*The HNF are equal*)
    and gs: "set gs  carrier_vec n" and len_gs: "length gs = m"
  shows "lattice_of gs = lattice_of fs_init" "LLL_with_assms n m gs α"
proof -                                           
  have "lattice_of fs_init = lattice_of (rows H1)"
    by (rule lattice_of_HNF[OF sound_HNF P1_H1 fs_init], simp add: len)
  also have "... = lattice_of (rows H2)" using H1_H2 by auto
  also have "... = lattice_of gs" 
    by (rule lattice_of_HNF[symmetric, OF sound_HNF P2_H2 gs len_gs])
  finally show "lattice_of gs = lattice_of fs_init" ..
    have invertible_P1: "invertible_mat P1" 
      using sound_HNF P1_H1 unfolding is_sound_HNF_def
      by (metis (mono_tags, lifting) case_prodD)
  have invertible_P2: "invertible_mat P2"
      using sound_HNF P2_H2 unfolding is_sound_HNF_def
      by (metis (mono_tags, lifting) case_prodD)
    have P2: "P2  carrier_mat m m" 
      using sound_HNF P2_H2 unfolding is_sound_HNF_def
      by (metis (no_types, lifting) len_gs case_prodD mat_of_rows_carrier(2))
    obtain inv_P2 where P2_inv_P2: "inverts_mat P2 inv_P2" and inv_P2_P2: "inverts_mat inv_P2 P2"
    and inv_P2: "inv_P2  carrier_mat m m"
      using P2 invertible_P2 obtain_inverse_matrix by blast
    have P1: "P1  carrier_mat m m" 
      using sound_HNF P1_H1 unfolding is_sound_HNF_def
      by (metis (no_types, lifting) len case_prodD mat_of_rows_carrier(2))
    have H1: "H1  carrier_mat m n" 
      using sound_HNF P1_H1 unfolding is_sound_HNF_def
      by (metis (no_types, lifting) case_prodD len mat_of_rows_carrier(2) mat_of_rows_carrier(3))
    have H2: "H2  carrier_mat m n" 
      using sound_HNF P2_H2 unfolding is_sound_HNF_def
      by (metis (no_types, lifting) len_gs case_prodD mat_of_rows_carrier(2) mat_of_rows_carrier(3))
    have P2_H2: "P2 * H2 = mat_of_rows n gs"
      by (smt P2_H2 sound_HNF case_prodD is_sound_HNF_def)
    have P1_H1_fs: "P1 * H1 = mat_of_rows n fs_init"
      by (smt P1_H1 sound_HNF case_prodD is_sound_HNF_def)
    obtain inv_P1 where P1_inv_P1: "inverts_mat P1 inv_P1" and inv_P1_P1: "inverts_mat inv_P1 P1"
    and inv_P1: "inv_P1  carrier_mat m m"
      using P1 invertible_P1 obtain_inverse_matrix by blast
  show "LLL_with_assms n m gs α"
  proof (rule LLL_change_basis(2)[OF gs len_gs])
    show "P1 * inv_P2  carrier_mat m m" using P1 inv_P2 by auto
    have "mat_of_rows n fs_init = P1 * H1" using sound_HNF P2_H2 unfolding is_sound_HNF_def
      by (metis (mono_tags, lifting) P1_H1 case_prodD)
    also have "... = P1 * inv_P2 * P2 * H1"
      by (smt P1 P2 assoc_mult_mat carrier_matD(1) inv_P2 inv_P2_P2 inverts_mat_def right_mult_one_mat)
    also have "... = P1 * inv_P2 * P2 * H2" using H1_H2 by blast
    also have "... = P1 * inv_P2 * (P2 * H2)" 
      using H2 P2 P1 * inv_P2  carrier_mat m m assoc_mult_mat by blast
    also have "... = P1 * (inv_P2 * P2 * H2)"
      by (metis H2 P1 * H1 = P1 * inv_P2 * P2 * H1 P1 * inv_P2 * P2 * H2 = P1 * inv_P2 * (P2 * H2) 
          H1_H2 carrier_matD(1) inv_P2 inv_P2_P2 inverts_mat_def left_mult_one_mat)
    also have "... = P1 * (inv_P2 * (P2 * H2))" using H2 P2 inv_P2 by auto
    also have "... =  P1 * inv_P2 * mat_of_rows n gs"
      using P2_H2 P1 * (inv_P2 * P2 * H2) = P1 * (inv_P2 * (P2 * H2)) 
        P1 * inv_P2 * (P2 * H2) = P1 * (inv_P2 * P2 * H2) by auto
    finally show "mat_of_rows n fs_init = P1 * inv_P2 * mat_of_rows n gs" .
    show "P2 * inv_P1  carrier_mat m m" 
      using P2 inv_P1 by auto
    have "mat_of_rows n gs = P2 * H2" using sound_HNF P2_H2 unfolding is_sound_HNF_def by metis
    also have "... = P2 * inv_P1 * P1 * H2"
      by (smt P1 P2 assoc_mult_mat carrier_matD(1) inv_P1 inv_P1_P1 inverts_mat_def right_mult_one_mat)
    also have "... = P2 * inv_P1 * P1 * H1" using H1_H2 by blast
    also have "... = P2 * inv_P1 * (P1 * H1)" 
      using H1 P1 P2 * inv_P1  carrier_mat m m assoc_mult_mat by blast
    also have "... = P2 * (inv_P1 * P1 * H1)"
      by (metis H2 P2 * H2 = P2 * inv_P1 * P1 * H2 P2 * inv_P1 * P1 * H1 = P2 * inv_P1 * (P1 * H1) 
          H1_H2 carrier_matD(1) inv_P1 inv_P1_P1 inverts_mat_def left_mult_one_mat)
    also have "... = P2 * (inv_P1 * (P1 * H1))" using H1 P1 inv_P1 by auto
    also have "... =  P2 * inv_P1 * mat_of_rows n fs_init"
      using P1_H1_fs P2 * (inv_P1 * P1 * H1) = P2 * (inv_P1 * (P1 * H1)) 
        P2 * inv_P1 * (P1 * H1) = P2 * (inv_P1 * P1 * H1) by auto
    finally show "mat_of_rows n gs = P2 * inv_P1 * mat_of_rows n fs_init" .
  qed
qed

end

text ‹Now, we need to generalize some lemmas.›

context vec_module
begin

(*Generalized version of thm vec_space.finsum_index, now in vec_module*)
lemma finsum_index:
  assumes i: "i < n"
    and f: "f  A  carrier_vec n"
    and A: "A  carrier_vec n"
  shows "finsum V f A $ i = sum (λx. f x $ i) A"
  using A f
proof (induct A rule: infinite_finite_induct)
  case empty
    then show ?case using i by simp next
  case (insert x X)
    then have Xf: "finite X"
      and xX: "x  X"
      and x: "x  carrier_vec n"
      and X: "X  carrier_vec n"
      and fx: "f x  carrier_vec n"
      and f: "f  X  carrier_vec n" by auto
    have i2: "i < dim_vec (finsum V f X)"
      using i finsum_closed[OF f] by auto
    have ix: "i < dim_vec x" using x i by auto
    show ?case
      unfolding finsum_insert[OF Xf xX f fx]
      unfolding sum.insert[OF Xf xX]
      unfolding index_add_vec(1)[OF i2]
      using insert lincomb_def
      by auto
qed (insert i, auto)

(*Generalized version of thm vec_space.mat_of_rows_mult_as_finsum, now in vec_module*)
lemma mat_of_rows_mult_as_finsum:
  assumes "v  carrier_vec (length lst)" " i. i < length lst  lst ! i  carrier_vec n"
  defines "f l  sum (λ i. if l = lst ! i then v $ i else 0) {0..<length lst}"
  shows mat_of_cols_mult_as_finsum:"mat_of_cols n lst *v v = lincomb f (set lst)"
proof -
  from assms have " i < length lst. lst ! i  carrier_vec n" by blast
  note an = all_nth_imp_all_set[OF this] hence slc:"set lst  carrier_vec n" by auto
  hence dn [simp]:" x. x  set lst  dim_vec x = n" by auto
  have dl [simp]:"dim_vec (lincomb f (set lst)) = n" using an
    by (simp add: slc)
  show ?thesis proof
    show "dim_vec (mat_of_cols n lst *v v) = dim_vec (lincomb f (set lst))" using assms(1,2) by auto
    fix i assume i:"i < dim_vec (lincomb f (set lst))" hence i':"i < n" by auto
    with an have fcarr:"(λv. f v v v)  set lst  carrier_vec n" by auto
    from i' have "(mat_of_cols n lst *v v) $ i = row (mat_of_cols n lst) i  v" by auto
    also have " = (ia = 0..<dim_vec v. lst ! ia $ i * v $ ia)"
      unfolding mat_of_cols_def row_def scalar_prod_def
      apply(rule sum.cong[OF refl]) using i an assms(1) by auto
    also have " = (ia = 0..<length lst. lst ! ia $ i * v $ ia)" using assms(1) by auto
    also have " = (xset lst. f x * x $ i)"
      unfolding f_def sum_distrib_right apply (subst sum.swap)
      apply(rule sum.cong[OF refl])
      unfolding if_distrib if_distribR mult_zero_left sum.delta[OF finite_set] by auto
    also have " = (xset lst. (f x v x) $ i)"
      apply(rule sum.cong[OF refl],subst index_smult_vec) using i slc by auto
    also have " = (Vvset lst. f v v v) $ i" 
      unfolding finsum_index[OF i' fcarr slc] by auto
    finally show "(mat_of_cols n lst *v v) $ i = lincomb f (set lst) $ i"
      by (auto simp:lincomb_def)
  qed
qed


lemma lattice_of_altdef_lincomb:
  assumes "set fs  carrier_vec n"
  shows "lattice_of fs = {y. f. lincomb (of_int  f) (set fs) = y}"
  unfolding lincomb_def lattice_of_altdef[OF assms] image_def by auto

end

context vec_module
begin

(*Generalized version of thm idom_vec.lincomb_as_lincomb_list, now in vec_module*)
lemma lincomb_as_lincomb_list:
  fixes ws f
  assumes s: "set ws  carrier_vec n"
  shows "lincomb f (set ws) = lincomb_list (λi. if j<i. ws!i = ws!j then 0 else f (ws ! i)) ws"
  using assms
proof (induct ws rule: rev_induct)
  case (snoc a ws)
  let ?f = "λi. if j<i. ws ! i = ws ! j then 0 else f (ws ! i)"
  let ?g = "λi. (if j<i. (ws @ [a]) ! i = (ws @ [a]) ! j then 0 else f ((ws @ [a]) ! i)) v (ws @ [a]) ! i"
  let ?g2= "(λi. (if j<i. ws ! i = ws ! j then 0 else f (ws ! i)) v ws ! i)"
  have [simp]: "v. v  set ws  v  carrier_vec n" using snoc.prems(1) by auto
  then have ws: "set ws  carrier_vec n" by auto
  have hyp: "lincomb f (set ws) = lincomb_list ?f ws"
    by (intro snoc.hyps ws)  
  show ?case
  proof (cases "aset ws")
    case True    
    have g_length: "?g (length ws) = 0v n" using True
      by (auto, metis in_set_conv_nth nth_append)
    have "(map ?g [0..<length (ws @ [a])]) = (map ?g [0..<length ws]) @ [?g (length ws)]"
       by auto
    also have "... = (map ?g [0..<length ws]) @ [0v n]" using g_length by simp
    finally have map_rw: "(map ?g [0..<length (ws @ [a])]) = (map ?g [0..<length ws]) @ [0v n]" .
    have "M.sumlist (map ?g2 [0..<length ws]) = M.sumlist (map ?g [0..<length ws])"
      by (rule arg_cong[of _ _ "M.sumlist"], intro nth_equalityI, auto simp add: nth_append)
    also have "... =  M.sumlist (map ?g [0..<length ws]) + 0v n "
      by (metis M.r_zero calculation hyp lincomb_closed lincomb_list_def ws)
    also have "... = M.sumlist (map ?g [0..<length ws] @ [0v n])" 
      by (rule M.sumlist_snoc[symmetric], auto simp add: nth_append)
    finally have summlist_rw: "M.sumlist (map ?g2 [0..<length ws]) 
      = M.sumlist (map ?g [0..<length ws] @ [0v n])" .
    have "lincomb f (set (ws @ [a])) = lincomb f (set ws)" using True unfolding lincomb_def
      by (simp add: insert_absorb)
    thus ?thesis 
      unfolding hyp lincomb_list_def map_rw summlist_rw
      by auto
  next
    case False    
    have g_length: "?g (length ws) = f a v a" using False by (auto simp add: nth_append)
    have "(map ?g [0..<length (ws @ [a])]) = (map ?g [0..<length ws]) @ [?g (length ws)]"
       by auto
    also have "... = (map ?g [0..<length ws]) @ [(f a v a)]" using g_length by simp
    finally have map_rw: "(map ?g [0..<length (ws @ [a])]) = (map ?g [0..<length ws]) @ [(f a v a)]" .
    have summlist_rw: "M.sumlist (map ?g2 [0..<length ws]) = M.sumlist (map ?g [0..<length ws])"
      by (rule arg_cong[of _ _ "M.sumlist"], intro nth_equalityI, auto simp add: nth_append)
    have "lincomb f (set (ws @ [a])) = lincomb f (set (a # ws))" by auto
    also have "... = (Vvset (a # ws). f v v v)" unfolding lincomb_def ..
    also have "... = (Vv insert a (set ws). f v v v)" by simp    
    also have "... = (f a v a) + (Vv (set ws). f v v v)"
    proof (rule finsum_insert)
      show "finite (set ws)" by auto
      show "a  set ws" using False by auto
      show "(λv. f v v v)  set ws  carrier_vec n"
        using snoc.prems(1) by auto
      show "f a v a  carrier_vec n" using snoc.prems by auto
    qed
    also have "... = (f a v a) + lincomb f (set ws)" unfolding lincomb_def ..
    also have "... = (f a v a) + lincomb_list ?f ws" using hyp by auto
    also have "... =  lincomb_list ?f ws  + (f a v a)"
      using M.add.m_comm lincomb_list_carrier snoc.prems by auto
    also have "... = lincomb_list (λi. if j<i. (ws @ [a]) ! i 
      = (ws @ [a]) ! j then 0 else f ((ws @ [a]) ! i)) (ws @ [a])" 
    proof (unfold lincomb_list_def map_rw summlist_rw, rule M.sumlist_snoc[symmetric])
      show "set (map ?g [0..<length ws])  carrier_vec n" using snoc.prems
        by (auto simp add: nth_append)
      show "f a v a  carrier_vec n"
        using snoc.prems by auto
    qed
    finally show ?thesis .
  qed
qed auto
end

context 
begin

interpretation vec_module "TYPE(int)" .

lemma lattice_of_cols_as_mat_mult:
  assumes A: "A  carrier_mat n nc" (*Integer matrix*)
  shows "lattice_of (cols A) = {ycarrier_vec (dim_row A). xcarrier_vec (dim_col A). A *v x = y}"
proof -
  let ?ws = "cols A"
  have set_cols_in: "set (cols A)  carrier_vec n" using A unfolding cols_def by auto
  have "lincomb (of_int  f)(set  ?ws)  carrier_vec (dim_row A)" for f 
    using lincomb_closed A
    by (metis (full_types) carrier_matD(1) cols_dim lincomb_closed)
  moreover have "xcarrier_vec (dim_col A). A *v x = lincomb (of_int  f) (set (cols A))" for f
  proof -    
    let ?g = "(λv. of_int (f v))"
    let ?g' = "(λi. if j<i. ?ws ! i = ?ws ! j then 0 else ?g (?ws ! i))"           
    have "lincomb (of_int  f) (set (cols A)) = lincomb ?g (set ?ws)" unfolding o_def by auto
    also have "... = lincomb_list ?g' ?ws" 
      by (rule lincomb_as_lincomb_list[OF set_cols_in])
    also have "... = mat_of_cols n ?ws *v vec (length ?ws) ?g'" 
      by (rule lincomb_list_as_mat_mult, insert set_cols_in A, auto)
    also have "... = A *v (vec (length ?ws) ?g')" using mat_of_cols_cols A by auto
    finally show ?thesis by auto
  qed 
  moreover have "f. A *v x = lincomb (of_int  f) (set (cols A))" 
    if Ax: "A *v x  carrier_vec (dim_row A)" and x: "x  carrier_vec (dim_col A)" for x 
  proof -
    let ?c = "λi. x $ i"
    have x_vec: "vec (length ?ws) ?c = x" using x by auto
    have "A *v x = mat_of_cols n ?ws *v vec (length ?ws) ?c" using mat_of_cols_cols A x_vec by auto
    also have "... = lincomb_list ?c ?ws"
      by (rule lincomb_list_as_mat_mult[symmetric], insert set_cols_in A, auto)
    also have "... = lincomb (mk_coeff ?ws ?c) (set ?ws)" 
      by (rule lincomb_list_as_lincomb, insert set_cols_in A, auto)    
    finally show ?thesis by auto
  qed
  ultimately show ?thesis unfolding lattice_of_altdef_lincomb[OF set_cols_in]
    by (metis (mono_tags, hide_lams))
qed


corollary lattice_of_as_mat_mult:
  assumes fs: "set fs  carrier_vec n"
  shows "lattice_of fs = {ycarrier_vec n. xcarrier_vec (length fs). (mat_of_cols n fs) *v x = y}"
proof -
  have cols_eq: "cols (mat_of_cols n fs) = fs" using cols_mat_of_cols[OF fs] by simp
  have m: "(mat_of_cols n fs)  carrier_mat n (length fs)" using mat_of_cols_carrier(1) by auto
  show ?thesis using lattice_of_cols_as_mat_mult[OF m] unfolding cols_eq using m by auto
qed
end

context vec_space
begin

lemma lin_indpt_cols_imp_det_not_0:
  fixes A::"'a mat"
  assumes A: "A  carrier_mat n n" and li: "lin_indpt (set (cols A))" and d: "distinct (cols A)" 
  shows "det A  0"  
  using A li d det_rank_iff lin_indpt_full_rank by blast

corollary lin_indpt_rows_imp_det_not_0:
  fixes A::"'a mat"
  assumes A: "A  carrier_mat n n" and li: "lin_indpt (set (rows A))" and d: "distinct (rows A)" 
  shows "det A  0"  
  using A li d det_rank_iff lin_indpt_full_rank
  by (metis (full_types) Determinant.det_transpose cols_transpose transpose_carrier_mat)
end

context LLL
begin

lemma eq_lattice_imp_mat_mult_invertible_cols:
  assumes fs: "set fs  carrier_vec n"
  and gs: "set gs  carrier_vec n"  and ind_fs: "lin_indep fs" (*fs is a basis*)
  and length_fs: "length fs = n" and length_gs: "length gs = n" (*For the moment, only valid for square matrices*)
  and l: "lattice_of fs = lattice_of gs" 
shows "Q  carrier_mat n n. invertible_mat Q  mat_of_cols n fs = mat_of_cols n gs * Q"
proof (cases "n=0")
  case True
  show ?thesis
    by (rule bexI[of _ "1m 0"], insert True assms, auto) 
next
  case False
  hence n: "0<n" by simp
  have ind_RAT_fs: "gs.lin_indpt (set (RAT fs))" using ind_fs
    by (simp add: cof_vec_space.lin_indpt_list_def)
  have fs_carrier: "mat_of_cols n fs  carrier_mat n n" by (simp add: length_fs carrier_matI)
  let ?f = "(λi. SOME x. xcarrier_vec (length gs)  (mat_of_cols n gs) *v x = fs ! i)"
  let ?cols_Q = "map ?f [0..<length fs]"
  let ?Q = "mat_of_cols n ?cols_Q"
  show ?thesis
  proof (rule bexI[of _ ?Q], rule conjI)
    show Q: "?Q  carrier_mat n n" using length_fs by auto
    show fs_gs_Q: "mat_of_cols n fs = mat_of_cols n gs * ?Q"
    proof (rule mat_col_eqI)
      fix j assume j: "j < dim_col (mat_of_cols n gs * ?Q)"
      have j2: "j<n" using j Q length_gs by auto
      have fs_j_in_gs: "fs ! j  lattice_of gs" using fs l basis_in_latticeI j by auto
      have fs_j_carrier_vec: "fs ! j  carrier_vec n"
        using fs_j_in_gs gs lattice_of_as_mat_mult by blast      
      let ?x = "SOME x. xcarrier_vec (length gs)  (mat_of_cols n gs) *v x = fs ! j"
      have "?xcarrier_vec (length gs)  (mat_of_cols n gs) *v ?x = fs ! j"
        by (rule someI_ex, insert fs_j_in_gs lattice_of_as_mat_mult[OF gs], auto)
      hence x: "?x  carrier_vec (length gs)"
        and gs_x: "(mat_of_cols n gs) *v ?x = fs ! j" by blast+
      have "col ?Q j = ?cols_Q ! j"
      proof (rule col_mat_of_cols)
        show "j < length (map ?f [0..<length fs])" using length_fs j2 by auto
        have "map ?f [0..<length fs] ! j = ?f ([0..<length fs] ! j)" 
          by (rule nth_map, insert j2 length_fs, auto) 
        also have "... = ?f j" by (simp add: length_fs j2)
        also have "...  carrier_vec n" using x length_gs by auto        
        finally show "map ?f [0..<length fs] ! j  carrier_vec n" .
      qed
      also have "... = ?f ([0..<length fs] ! j)" 
        by (rule nth_map, insert j2 length_fs, auto)
      also have "... = ?x" by (simp add: length_fs j2)
      finally have col_Qj_x: "col ?Q j = ?x" .
      have "col (mat_of_cols n fs) j = fs ! j"
        by (metis (no_types, lifting) j Q fs length_fs carrier_matD(2) cols_mat_of_cols cols_nth
            index_mult_mat(3) mat_of_cols_carrier(3))
      also have "... = (mat_of_cols n gs) *v ?x" using gs_x by auto
      also have "... = (mat_of_cols n gs) *v (col ?Q j)" unfolding col_Qj_x by simp
      also have "... = col (mat_of_cols n gs * ?Q) j"
        by (rule col_mult2[symmetric, OF _ Q j2], insert length_gs mat_of_cols_def, auto)
      finally show "col (mat_of_cols n fs) j = col (mat_of_cols n gs * ?Q) j" .      
    qed (insert length_gs gs, auto)
    show "invertible_mat ?Q"
    (* Sketch of the proof:
      1) fs = gs * Q, proved previously
      2) gs = fs * Q', similar proof as the previous one.
      3) fs = fs * Q' * Q
      4) fs * (?Q' * ?Q - 1m n) = 0m n n and hence (?Q' * ?Q - 1m n) = 0 since fs independent
      5) det ?Q' = det ?Q = det 1 = 1, then det ?Q = ±1 and ?Q invertible since the determinant 
         divides a unit.
    *)
    proof -
      let ?f' = "(λi. SOME x. xcarrier_vec (length fs)  (mat_of_cols n fs) *v x = gs ! i)"
      let ?cols_Q' = "map ?f' [0..<length gs]"
      let ?Q' = "mat_of_cols n ?cols_Q'"
      have Q': "?Q'  carrier_mat n n" using length_gs by auto
      have gs_fs_Q': "mat_of_cols n gs = mat_of_cols n fs * ?Q'"
      proof (rule mat_col_eqI)
        fix j assume j: "j < dim_col (mat_of_cols n fs * ?Q')"
        have j2: "j<n" using j Q length_gs by auto
        have gs_j_in_fs: "gs ! j  lattice_of fs" using gs l basis_in_latticeI j by auto
        have gs_j_carrier_vec: "gs ! j  carrier_vec n"
          using gs_j_in_fs fs lattice_of_as_mat_mult by blast      
        let ?x = "SOME x. xcarrier_vec (length fs)  (mat_of_cols n fs) *v x = gs ! j"
        have "?xcarrier_vec (length fs)  (mat_of_cols n fs) *v ?x = gs ! j"
          by (rule someI_ex, insert gs_j_in_fs lattice_of_as_mat_mult[OF fs], auto)
        hence x: "?x  carrier_vec (length fs)"
          and fs_x: "(mat_of_cols n fs) *v ?x = gs ! j" by blast+
        have "col ?Q' j = ?cols_Q' ! j"
        proof (rule col_mat_of_cols)
          show "j < length (map ?f' [0..<length gs])" using length_gs j2 by auto
          have "map ?f' [0..<length gs] ! j = ?f' ([0..<length gs] ! j)" 
            by (rule nth_map, insert j2 length_gs, auto) 
          also have "... = ?f' j" by (simp add: length_gs j2)
          also have "...  carrier_vec n" using x length_fs by auto        
          finally show "map ?f' [0..<length gs] ! j  carrier_vec n" .
        qed
        also have "... = ?f' ([0..<length gs] ! j)" 
          by (rule nth_map, insert j2 length_gs, auto)
        also have "... = ?x" by (simp add: length_gs j2)
        finally have col_Qj_x: "col ?Q' j = ?x" .
        have "col (mat_of_cols n gs) j = gs ! j" by (simp add: length_gs gs_j_carrier_vec j2)
        also have "... = (mat_of_cols n fs) *v ?x" using fs_x by auto
        also have "... = (mat_of_cols n fs) *v (col ?Q' j)" unfolding col_Qj_x by simp
        also have "... = col (mat_of_cols n fs * ?Q') j"
          by (rule col_mult2[symmetric, OF _ Q' j2], insert length_fs mat_of_cols_def, auto)
        finally show "col (mat_of_cols n gs) j = col (mat_of_cols n fs * ?Q') j" .      
      qed (insert length_fs fs, auto)
      
      have det_fs_not_zero: "rat_of_int (det (mat_of_cols n fs))  0"
      proof -
        let ?A = "(of_int_hom.mat_hom (mat_of_cols n fs)):: rat mat"
        have "rat_of_int (det (mat_of_cols n fs)) = det ?A"
          by simp
        moreover have "det ?A  0"
        proof (rule gs.lin_indpt_cols_imp_det_not_0[of ?A])
          have c_eq: "(set (cols ?A)) = set (RAT fs)"
            by (metis assms(3) cof_vec_space.lin_indpt_list_def cols_mat_of_cols fs mat_of_cols_map)
          show "?A  carrier_mat n n" by (simp add: fs_carrier)
          show "gs.lin_indpt (set (cols ?A))" using ind_RAT_fs c_eq by auto
          show "distinct (cols ?A)"
            by (metis ind_fs cof_vec_space.lin_indpt_list_def cols_mat_of_cols fs mat_of_cols_map)
        qed
        ultimately show ?thesis by auto
      qed
      have Q'Q: "?Q' * ?Q  carrier_mat n n" using Q Q' mult_carrier_mat by blast
      have fs_fs_Q'Q: "mat_of_cols n fs = mat_of_cols n fs * ?Q' * ?Q" using gs_fs_Q' fs_gs_Q by presburger
      hence "0m n n = mat_of_cols n fs * ?Q' * ?Q - mat_of_cols n fs" using length_fs by auto
      also have "... = mat_of_cols n fs * ?Q' * ?Q - mat_of_cols n fs * 1m n"
        using fs_carrier by auto
      also have "... = mat_of_cols n fs * (?Q' * ?Q) - mat_of_cols n fs * 1m n"
        using Q Q' fs_carrier by auto
      also have "... = mat_of_cols n fs * (?Q' * ?Q - 1m n)"
        by (rule mult_minus_distrib_mat[symmetric, OF fs_carrier Q'Q], auto)      
      finally have "mat_of_cols n fs * (?Q' * ?Q - 1m n) = 0m n n" ..
      have "det (?Q' * ?Q) = 1"
        by (smt Determinant.det_mult Q Q' Q'Q fs_fs_Q'Q assoc_mult_mat det_fs_not_zero 
            fs_carrier mult_cancel_left2 of_int_code(2))
      hence det_Q'_Q_1: "det ?Q * det ?Q' = 1"
        by (metis (no_types, lifting) Determinant.det_mult Groups.mult_ac(2) Q Q')
      hence "det ?Q = 1  det ?Q = -1" by (rule pos_zmult_eq_1_iff_lemma)
      thus ?thesis using invertible_iff_is_unit_JNF[OF Q] by fastforce
    qed
  qed
qed


corollary eq_lattice_imp_mat_mult_invertible_rows:
  assumes fs: "set fs  carrier_vec n"
  and gs: "set gs  carrier_vec n"  and ind_fs: "lin_indep fs" (*fs is a basis*)
  and length_fs: "length fs = n" and length_gs: "length gs = n" (*For the moment, only valid for square matrices*)
  and l: "lattice_of fs = lattice_of gs" 
shows "P  carrier_mat n n. invertible_mat P  mat_of_rows n fs = P * mat_of_rows n gs"
proof -
  obtain Q where Q: "Q  carrier_mat n n" and inv_Q: "invertible_mat Q" 
    and fs_gs_Q: "mat_of_cols n fs = mat_of_cols n gs * Q" 
    using eq_lattice_imp_mat_mult_invertible_cols[OF assms] by auto
  have "invertible_mat QT" by (simp add: inv_Q invertible_mat_transpose)
  moreover have "mat_of_rows n fs = QT * mat_of_rows n gs" using fs_gs_Q
    by (metis Matrix.transpose_mult Q length_gs mat_of_cols_carrier(1) transpose_mat_of_cols)
  moreover have "QT  carrier_mat n n" using Q by auto
  ultimately show ?thesis by blast
qed
end

subsubsection ‹Missing results›

text ‹This is a new definition for upper triangular matrix, valid for rectangular matrices. 
This definition will allow us to prove that echelon form implies upper triangular for any matrix.›

definition "upper_triangular' A = (i < dim_row A.  j<dim_col A. j < i  A $$ (i,j) = 0)"

lemma upper_triangular'D[elim] :
  "upper_triangular' A  j<dim_col A  j < i  i < dim_row A  A $$ (i,j) = 0"
unfolding upper_triangular'_def by auto

lemma upper_triangular'I[intro] :
  "(i j. j<dim_col A  j < i  i < dim_row A  A $$ (i,j) = 0)  upper_triangular' A"
  unfolding upper_triangular'_def by auto

lemma prod_list_abs(*[simp]?*):
  fixes xs:: "int list"
  shows "prod_list (map abs xs) = abs (prod_list xs)"
  by (induct xs, auto simp add: abs_mult)

lemma euclid_ext2_works:
  assumes "euclid_ext2 a b = (p,q,u,v,d)"
  shows "p*a+q*b = d" and "d = gcd a b" and "gcd a b * u = -b" and "gcd a b * v = a"
  and "u = -b div gcd a b" and "v = a div gcd a b"
  using assms unfolding euclid_ext2_def
  by (auto simp add: bezout_coefficients_fst_snd)

lemma res_function_euclidean2: 
  "res_function (λb n::'a::{unique_euclidean_ring}. n mod b)"
proof- 
  have "n mod b = n" if "b=0" for n b::"'a :: unique_euclidean_ring" using that by auto
  hence "res_function_euclidean = (λb n::'a. n mod b)" 
    by (unfold fun_eq_iff res_function_euclidean_def, auto)
  thus ?thesis using res_function_euclidean by auto
qed

lemma mult_row_1_id:
  fixes A:: "'a::semiring_1^'n^'m"
  shows "mult_row A b 1 = A" unfolding mult_row_def by vector

text ‹Results about appending rows›

lemma row_append_rows1:
  assumes A: "A  carrier_mat m n"
  and B: "B  carrier_mat p n"
  assumes i: "i < dim_row A"
  shows "Matrix.row (A @r B) i = Matrix.row A i"  
proof (rule eq_vecI)
  have AB_carrier[simp]: "(A @r B)  carrier_mat (m+p) n" by (rule carrier_append_rows[OF A B])
  thus "dim_vec (Matrix.row (A @r B) i) = dim_vec (Matrix.row A i)"
    using A B by (auto, insert carrier_matD(2), blast)
  fix j assume j: "j < dim_vec (Matrix.row A i)" 
  have "Matrix.row (A @r B) i $v j = (A @r B) $$ (i, j)"
    by (metis AB_carrier Matrix.row_def j A carrier_matD(2) index_row(2) index_vec)
  also have "... = (if i < dim_row A then A $$ (i, j) else B $$ (i - m, j))"
    by (rule append_rows_nth, insert assms j, auto)
  also have "... = A$$ (i,j)" using i by simp
  finally show "Matrix.row (A @r B) i $v j = Matrix.row A i $v j" using i j by simp  
qed

lemma row_append_rows2:
  assumes A: "A  carrier_mat m n"
  and B: "B  carrier_mat p n"
  assumes i: "i  {m..<m+p}"
  shows "Matrix.row (A @r B) i = Matrix.row B (i - m)"
proof (rule eq_vecI)
  have AB_carrier[simp]: "(A @r B)  carrier_mat (m+p) n" by (rule carrier_append_rows[OF A B])
  thus "dim_vec (Matrix.row (A @r B) i) = dim_vec (Matrix.row B (i-m))"
    using A B by (auto, insert carrier_matD(2), blast)
  fix j assume j: "j < dim_vec (Matrix.row B (i-m))" 
  have "Matrix.row (A @r B) i $v j = (A @r B) $$ (i, j)"
    by (metis AB_carrier Matrix.row_def j B carrier_matD(2) index_row(2) index_vec)
  also have "... = (if i < dim_row A then A $$ (i, j) else B $$ (i - m, j))"
    by (rule append_rows_nth, insert assms j, auto)
  also have "... = B $$ (i - m, j)" using i A by simp
  finally show "Matrix.row (A @r B) i $v j = Matrix.row B (i-m) $v j" using i j A B by auto  
qed


lemma rows_append_rows:
  assumes A: "A  carrier_mat m n"
  and B: "B  carrier_mat p n"
shows "Matrix.rows (A @r B) = Matrix.rows A @ Matrix.rows B"
proof -
  have AB_carrier: "(A @r B)  carrier_mat (m+p) n" 
    by (rule carrier_append_rows, insert A B, auto)
  hence 1: "dim_row (A @r B) = dim_row A + dim_row B" using A B by blast
  moreover have "Matrix.row (A @r B) i = (Matrix.rows A @ Matrix.rows B) ! i"
    if i: "i < dim_row (A @r B)" for i
  proof (cases "i<dim_row A")
    case True
    have "Matrix.row (A @r B) i = Matrix.row A i" using A True B row_append_rows1 by blast
    also have "... = Matrix.rows A ! i" unfolding Matrix.rows_def using True by auto
    also have "... = (Matrix.rows A @ Matrix.rows B) ! i" using True by (simp add: nth_append)
    finally show ?thesis .
  next
    case False
    have i_mp: "i < m + p" using AB_carrier A B i by fastforce
    have "Matrix.row (A @r B) i = Matrix.row B (i-m)" using A False B i row_append_rows2 i_mp
      by (smt AB_carrier atLeastLessThan_iff carrier_matD(1) le_add1
          linordered_semidom_class.add_diff_inverse row_append_rows2)
    also have "... = Matrix.rows B ! (i-m)" unfolding Matrix.rows_def using False i A 1 by auto
    also have "... = (Matrix.rows A @ Matrix.rows B) ! (i-m+m)"
      by (metis add_diff_cancel_right' A carrier_matD(1) length_rows not_add_less2 nth_append)
    also have "... =  (Matrix.rows A @ Matrix.rows B) ! i" using False A by auto
    finally show ?thesis .
  qed  
  ultimately show ?thesis unfolding list_eq_iff_nth_eq by auto  
qed



lemma append_rows_nth2:
  assumes A': "A'  carrier_mat m n"
  and B: "B  carrier_mat p n"
  and A_def: "A = (A' @r  B)"
  and a: "a<m" and ap: "a < p" and j: "j<n"
  shows "A $$ (a + m, j) = B $$ (a,j)" 
proof -
  have "A $$ (a + m, j) = (if a + m < dim_row A' then A' $$ (a + m, j) else B $$ (a + m - m, j))"
    unfolding A_def by (rule append_rows_nth[OF A' B _ j], insert ap a, auto)
  also have "... = B $$ (a,j)" using ap a A' by auto
  finally show ?thesis .
qed


lemma append_rows_nth3:
  assumes A': "A'  carrier_mat m n"
  and B: "B  carrier_mat p n"
  and A_def: "A = (A' @r  B)"
  and a: "am" and ap: "a < m + p" and j: "j<n"
  shows "A $$ (a, j) = B $$ (a-m,j)" 
proof -
  have "A $$ (a, j) = (if a < dim_row A' then A' $$ (a, j) else B $$ (a - m, j))"
    unfolding A_def by (rule append_rows_nth[OF A' B _ j], insert ap a, auto)
  also have "... = B $$ (a-m,j)" using ap a A' by auto
  finally show ?thesis .
qed


text ‹Results about submatrices›

lemma pick_first_id: assumes i: "i<n" shows "pick {0..<n} i = i"
proof -
  have "i = (card {a  {0..<n}. a < i})" using i
    by (auto, smt Collect_cong card_Collect_less_nat nat_SN.gt_trans)
  thus ?thesis using pick_card_in_set i
    by (metis atLeastLessThan_iff zero_order(1))
qed

lemma submatrix_index_id:
  assumes H: "H  carrier_mat m n" and i: "i<k1" and j: "j<k2"
  and k1: "k1m" and k2: "k2n"
  shows "(submatrix H {0..<k1} {0..<k2}) $$ (i,j) = H $$ (i,j)" 
proof -
  let ?I = "{0..<k1}"
  let ?J = "{0..<k2}"
  let ?H = "submatrix H ?I ?J"  
  have km: "k1m" and kn: "k2n" using k1 k2 by simp+
  have card_mk: "card {i. i < m  i < k1} = k1" using km 
    by (smt Collect_cong card_Collect_less_nat le_eq_less_or_eq nat_less_induct nat_neq_iff)
  have card_nk: "card {i. i < n  i < k2} = k2" using kn 
    by (smt Collect_cong card_Collect_less_nat le_eq_less_or_eq nat_less_induct nat_neq_iff)
  show ?thesis
  proof- 
    have pick_j: "pick ?J j = j" by (rule pick_first_id[OF j])
    have pick_i: "pick ?I i = i" by (rule pick_first_id[OF i])
    have "submatrix H ?I ?J $$ (i, j) = H $$ (pick ?I i, pick ?J j)" 
      by (rule submatrix_index, insert H i j card_mk card_nk, auto)
    also have "... = H $$ (i,j)" using pick_i pick_j by simp
    finally show ?thesis .
  qed
qed

lemma submatrix_carrier_first:
  assumes H: "H  carrier_mat m n"
  and k1: "k1  m" and k2: "k2  n"
  shows"submatrix H {0..<k1} {0..<k2}  carrier_mat k1 k2"
proof -  
  have km: "k1m" and kn: "k2n" using k1 k2 by simp+
  have card_mk: "card {i. i < m  i < k1} = k1" using km 
    by (smt Collect_cong card_Collect_less_nat le_eq_less_or_eq nat_less_induct nat_neq_iff)
  have card_nk: "card {i. i < n  i < k2} = k2" using kn 
    by (smt Collect_cong card_Collect_less_nat le_eq_less_or_eq nat_less_induct nat_neq_iff)
  show ?thesis
    by (smt Collect_cong H atLeastLessThan_iff card_mk card_nk carrier_matD 
        carrier_matI dim_submatrix zero_order(1))
qed



lemma Units_eq_invertible_mat:
  assumes "A  carrier_mat n n"
  shows "A  Group.Units (ring_mat TYPE('a::comm_ring_1) n b) = invertible_mat A" (is "?lhs = ?rhs")
proof -
  interpret m: ring "ring_mat TYPE('a) n b" by (rule ring_mat)
  show ?thesis
  proof
    assume "?lhs" thus "?rhs"
      unfolding Group.Units_def 
      by (insert assms, auto simp add: ring_mat_def invertible_mat_def inverts_mat_def)
  next
    assume "?rhs" 
    from this obtain B where AB: "A * B = 1m n" and BA: "B * A = 1m n" and B: "B  carrier_mat n n"
      by (metis assms carrier_matD(1) inverts_mat_def obtain_inverse_matrix)
    hence "xcarrier (ring_mat TYPE('a) n b). x ring_mat TYPE('a) n b A = 𝟭ring_mat TYPE('a) n b 
       A ring_mat TYPE('a) n b x = 𝟭ring_mat TYPE('a) n b"
      unfolding ring_mat_def by auto
    thus "?lhs" unfolding Group.Units_def using assms unfolding ring_mat_def by auto
  qed
qed

lemma map_first_rows_index:
  assumes "A  carrier_mat M n" and "m  M" and "i<m" and "ja<n"
  shows "map (Matrix.row A) [0..<m] ! i $v ja = A $$ (i, ja)"
  using assms by auto

lemma matrix_append_rows_eq_if_preserves:
  assumes A: "A  carrier_mat (m+p) n" and B: "B  carrier_mat p n"
    and eq: "i{m..<m+p}.j<n. A$$(i,j) = B $$ (i-m,j)"
  shows "A = mat_of_rows n [Matrix.row A i. i  [0..<m]] @r B" (is "_ = ?A' @r _")
proof (rule eq_matI)
  have A': "?A'  carrier_mat m n" by (simp add: mat_of_rows_def)
  hence A'B: "?A' @r B  carrier_mat (m+p) n" using B by blast
  show "dim_row A = dim_row (?A' @r B)" and "dim_col A = dim_col (?A' @r B)" using A'B A by auto
  fix i j assume i: "i < dim_row (?A' @r B)"
    and j: "j < dim_col (?A' @r B)" 
  have jn: "j<n" using A
    by (metis append_rows_def dim_col_mat(1) index_mat_four_block(3) index_zero_mat(3) 
        j mat_of_rows_def nat_arith.rule0)
  let ?xs = "(map (Matrix.row A) [0..<m])"
  show "A $$ (i, j) = (?A' @r B) $$ (i, j)"
  proof (cases "i<m")
    case True
    have "(?A' @r B) $$ (i, j) = ?A' $$ (i,j)"      
      by (metis (no_types, lifting) Nat.add_0_right True append_rows_def diff_zero i 
          index_mat_four_block index_zero_mat(3) j length_map length_upt mat_of_rows_carrier(2))
    also have "... = ?xs ! i $v j" 
      by (rule mat_of_rows_index, insert i True j, auto simp add: append_rows_def)
    also have "... = A $$ (i,j)"
      by (rule map_first_rows_index, insert assms A True i jn, auto)
    finally show ?thesis ..
  next
    case False
    have "(?A' @r B) $$ (i, j) = B $$ (i-m,j)"      
      by (smt (z3) A' carrier_matD(1) False append_rows_def i index_mat_four_block j jn length_map
          length_upt mat_of_rows_carrier(2,3))
    also have "... = A $$ (i,j)"
      by (metis False append_rows_def B eq atLeastLessThan_iff carrier_matD(1) diff_zero i 
          index_mat_four_block(2) index_zero_mat(2) jn le_add1 length_map length_upt 
          linordered_semidom_class.add_diff_inverse mat_of_rows_carrier(2))
    finally show ?thesis ..
  qed
qed

lemma invertible_mat_first_column_not0:
  fixes A::"'a :: comm_ring_1 mat"
  assumes A: "A  carrier_mat n n" and inv_A: "invertible_mat A" and n0: "0<n"
  shows "col A 0  (0v n)"
proof (rule ccontr)
  assume " ¬ col A 0  0v n" hence col_A0: "col A 0 = 0v n" by simp
  have "(det A dvd 1)" using inv_A invertible_iff_is_unit_JNF[OF A] by auto
  hence 1: "det A  0" by auto
  have "det A = (i<n. A $$ (i, 0) * Determinant.cofactor A i 0)" 
    by (rule laplace_expansion_column[OF A n0])
  also have "... = 0" 
    by (rule sum.neutral, insert col_A0 n0 A, auto simp add: col_def,
        metis Matrix.zero_vec_def index_vec mult_zero_left)
  finally show False using 1 by contradiction 
qed

lemma invertible_mat_mult_int:
  assumes "A = P * B" 
    and "P  carrier_mat n n"
    and "B  carrier_mat n n"
    and "invertible_mat P" 
    and "invertible_mat (map_mat rat_of_int B)"
  shows "invertible_mat (map_mat rat_of_int A)"
  by (metis (no_types, hide_lams) assms dvd_field_iff 
      invertible_iff_is_unit_JNF invertible_mult_JNF map_carrier_mat not_is_unit_0 
      of_int_hom.hom_0 of_int_hom.hom_det of_int_hom.mat_hom_mult)


lemma echelon_form_JNF_intro: 
  assumes "(i<dim_row A. is_zero_row_JNF i A  ¬ (j. j < dim_row A  j>i  ¬ is_zero_row_JNF j A))"
  and "(i j. i<j  j<dim_row A  ¬ (is_zero_row_JNF i A)  ¬ (is_zero_row_JNF j A) 
          ((LEAST n. A $$ (i, n)  0) < (LEAST n. A $$ (j, n)  0)))"
  shows "echelon_form_JNF A" using assms unfolding echelon_form_JNF_def by simp


lemma echelon_form_submatrix:
  assumes ef_H: "echelon_form_JNF H" and H: "H  carrier_mat m n"
  and k: "k  min m n"
shows "echelon_form_JNF (submatrix H {0..<k} {0..<k})" 
proof -
  let ?I = "{0..<k}"
  let ?H = "submatrix H ?I ?I"  
  have km: "km" and kn: "kn" using k by simp+
  have card_mk: "card {i. i < m  i < k} = k" using km 
    by (smt Collect_cong card_Collect_less_nat le_eq_less_or_eq nat_less_induct nat_neq_iff)
  have card_nk: "card {i. i < n  i < k} = k" using kn 
    by (smt Collect_cong card_Collect_less_nat le_eq_less_or_eq nat_less_induct nat_neq_iff)
  have H_ij: "H $$ (i,j) = (submatrix H ?I ?I) $$ (i,j)"  if i: "i<k" and j: "j<k" for i j
  proof- 
    have pick_j: "pick ?I j = j" by (rule pick_first_id[OF j])
    have pick_i: "pick ?I i = i" by (rule pick_first_id[OF i])
    have "submatrix H ?I ?I $$ (i, j) = H $$ (pick ?I i, pick ?I j)" 
      by (rule submatrix_index, insert H i j card_mk card_nk, auto)
    also have "... = H $$ (i,j)" using pick_i pick_j by simp
    finally show ?thesis ..
  qed
  have H'[simp]: "?H  carrier_mat k k" 
    using H dim_submatrix[of H "{0..<k}" "{0..<k}"] card_mk card_nk by auto
  show ?thesis
  proof (rule echelon_form_JNF_intro, auto)   
    fix i j assume iH'_0: "is_zero_row_JNF i ?H" and ij: "i < j" and j: "j < dim_row ?H"  
    have jm: "j<m"
      by (metis H' carrier_matD(1) j km le_eq_less_or_eq nat_SN.gt_trans)
    show "is_zero_row_JNF j ?H"
    proof (rule ccontr)
      assume j_not0_H': "¬ is_zero_row_JNF j ?H"
      define a where "a = (LEAST n. ?H $$ (j,n)  0)"
      have H'_ja: "?H $$ (j,a)  0" 
        by (metis (mono_tags) LeastI j_not0_H' a_def is_zero_row_JNF_def)
      have a: "a < dim_col ?H"
        by (smt j_not0_H' a_def is_zero_row_JNF_def linorder_neqE_nat not_less_Least order_trans_rules(19))
      have j_not0_H: "¬ is_zero_row_JNF j H"
        by (metis H' H'_ja H_ij a assms(2) basic_trans_rules(19) carrier_matD is_zero_row_JNF_def j kn le_eq_less_or_eq)
      hence i_not0_H: "¬ is_zero_row_JNF i H" using ef_H j ij unfolding echelon_form_JNF_def
        by (metis H' ¬ is_zero_row_JNF j H assms(2) carrier_matD(1) ij j km 
            not_less_iff_gr_or_eq order.strict_trans order_trans_rules(21))
      hence least_ab: "(LEAST n. H $$ (i, n)  0) < (LEAST n. H $$ (j, n)  0)" using jm
        using j_not0_H assms(2) echelon_form_JNF_def ef_H ij by blast
      define b where "b = (LEAST n. H $$ (i, n)  0)"
      have H_ib: "H $$ (i, b)  0"
        by (metis (mono_tags, lifting) LeastI b_def i_not0_H is_zero_row_JNF_def)
      have b: "b < dim_col ?H" using least_ab a unfolding a_def b_def
        by (metis (mono_tags, lifting) H' H'_ja H_ij a_def carrier_matD dual_order.strict_trans j nat_neq_iff not_less_Least)
      have H'_ib: "?H $$ (i,b)  0" using H_ib b H_ij H' ij j 
        by (metis H' carrier_matD dual_order.strict_trans ij j)
      hence "¬ is_zero_row_JNF i ?H" using b is_zero_row_JNF_def by blast
      thus False using iH'_0 by contradiction
    qed  
  next
    fix i j assume ij: "i < j" and j: "j < dim_row ?H"
    have jm: "j<m"
      by (metis H' carrier_matD(1) j km le_eq_less_or_eq nat_SN.gt_trans)
    assume not0_iH': "¬ is_zero_row_JNF i ?H"
      and not0_jH': "¬ is_zero_row_JNF j ?H"
    define a where "a = (LEAST n. ?H $$ (i, n)  0)"
    define b where "b = (LEAST n. ?H $$ (j, n)  0)"
    have H'_ia: "?H $$ (i,a)  0"
      by (metis (mono_tags) LeastI_ex a_def is_zero_row_JNF_def not0_iH')
    have H'_jb: "?H $$ (j,b)  0"
      by (metis (mono_tags) LeastI_ex b_def is_zero_row_JNF_def not0_jH')
    have a: "a < dim_row ?H"
      by (smt H' a_def carrier_matD is_zero_row_JNF_def less_trans linorder_neqE_nat not0_iH' not_less_Least)
    have b: "b < dim_row ?H"
      by (smt H' b_def carrier_matD is_zero_row_JNF_def less_trans linorder_neqE_nat not0_jH' not_less_Least)
    have a_eq: "a = (LEAST n. H $$ (i, n)  0)"
      by (smt H' H'_ia H_ij LeastI_ex a a_def carrier_matD(1) ij j linorder_neqE_nat not_less_Least order_trans_rules(19))
    have b_eq: "b = (LEAST n. H $$ (j, n)  0)"
      by (smt H' H'_jb H_ij LeastI_ex b b_def carrier_matD(1) ij j linorder_neqE_nat not_less_Least order_trans_rules(19)) 
    have not0_iH: "¬ is_zero_row_JNF i H" 
      by (metis H' H'_ia H_ij a H carrier_matD ij is_zero_row_JNF_def j kn le_eq_less_or_eq order.strict_trans)
    have not0_jH: "¬ is_zero_row_JNF j H" 
      by (metis H' H'_jb H_ij b H carrier_matD is_zero_row_JNF_def j kn le_eq_less_or_eq order.strict_trans)
    show "(LEAST n. ?H $$ (i, n)  0) < (LEAST n. ?H $$ (j, n)  0)"
      unfolding a_def[symmetric] b_def[symmetric] a_eq b_eq using not0_iH not0_jH ef_H ij jm H 
      unfolding echelon_form_JNF_def by auto
  qed
qed


lemma HNF_submatrix:
  assumes HNF_H: "Hermite_JNF associates res H" and H: "H  carrier_mat m n"
  and k: "k  min m n"
  shows "Hermite_JNF associates res (submatrix H {0..<k} {0..<k})" 
proof -
  let ?I = "{0..<k}"
  let ?H = "submatrix H ?I ?I"  
  have km: "km" and kn: "kn" using k by simp+
  have card_mk: "card {i. i < m  i < k} = k" using km 
    by (smt Collect_cong card_Collect_less_nat le_eq_less_or_eq nat_less_induct nat_neq_iff)
  have card_nk: "card {i. i < n  i < k} = k" using kn 
    by (smt Collect_cong card_Collect_less_nat le_eq_less_or_eq nat_less_induct nat_neq_iff)
  have H_ij: "H $$ (i,j) = (submatrix H ?I ?I) $$ (i,j)"  if i: "i<k" and j: "j<k" for i j
  proof- 
    have pick_j: "pick ?I j = j" by (rule pick_first_id[OF j])
    have pick_i: "pick ?I i = i" by (rule pick_first_id[OF i])
    have "submatrix H ?I ?I $$ (i, j) = H $$ (pick ?I i, pick ?I j)" 
      by (rule submatrix_index, insert H i j card_mk card_nk, auto)
    also have "... = H $$ (i,j)" using pick_i pick_j by simp
    finally show ?thesis ..
  qed
  have H'[simp]: "?H  carrier_mat k k" 
    using H dim_submatrix[of H "{0..<k}" "{0..<k}"] card_mk card_nk by auto
  have CS_ass: "Complete_set_non_associates associates" using HNF_H unfolding Hermite_JNF_def by simp
  moreover have CS_res: "Complete_set_residues res"  using HNF_H unfolding Hermite_JNF_def by simp
  have ef_H: "echelon_form_JNF H" using HNF_H unfolding Hermite_JNF_def by auto
  have ef_H': "echelon_form_JNF ?H"
    by (rule echelon_form_submatrix[OF ef_H H k])
  have HNF1: "?H $$ (i, LEAST n. ?H $$ (i, n)  0)  associates" 
    and HNF2: "(j<i. ?H $$ (j, LEAST n. ?H $$ (i, n)  0)
                res (?H $$ (i, LEAST n. ?H $$ (i, n)  0)))"
    if i: "i<dim_row ?H" and not0_iH': "¬ is_zero_row_JNF i ?H" for i
  proof -
    define a where "a = (LEAST n. ?H $$ (i, n)  0)"
    have im: "i<m"
      by (metis H' carrier_matD(1) km order.strict_trans2 that(1))
    have H'_ia: "?H $$ (i,a)  0"
      by (metis (mono_tags) LeastI_ex a_def is_zero_row_JNF_def not0_iH')
    have a: "a < dim_row ?H"
      by (smt H' a_def carrier_matD is_zero_row_JNF_def less_trans linorder_neqE_nat not0_iH' not_less_Least)
    have a_eq: "a = (LEAST n. H $$ (i, n)  0)"
      by (smt H' H'_ia H_ij LeastI_ex a a_def carrier_matD(1) i linorder_neqE_nat not_less_Least order_trans_rules(19))
    have H'_ia_H_ia: "?H $$ (i, a) = H $$ (i, a)"  by (metis H' H_ij a carrier_matD(1) i)
    have not'_iH: "¬ is_zero_row_JNF i H"
      by (metis H' H'_ia H'_ia_H_ia a assms(2) carrier_matD(1) carrier_matD(2) is_zero_row_JNF_def kn order.strict_trans2)
    thus "?H $$ (i, LEAST n. ?H $$ (i, n)  0)  associates" using im
      by (metis H'_ia_H_ia Hermite_JNF_def a_def a_eq HNF_H H carrier_matD(1))
    show "(j<i. ?H $$ (j, LEAST n. ?H $$ (i, n)  0)
                res (?H $$ (i, LEAST n. ?H $$ (i, n)  0)))" 
    proof -
      { fix nn :: nat
    have ff1: "n. ?H $$ (n, a) = H $$ (n, a)  ¬ n < k"
      by (metis (no_types) H' H_ij a carrier_matD(1))
      have ff2: "i < k"
    by (metis H' carrier_matD(1) that(1))
    then have "H $$ (nn, a)  res (H $$ (i, a))  H $$ (nn, a)  res (?H $$ (i, a))"
    using ff1 by (metis (no_types))
      moreover
      { assume "H $$ (nn, a)  res (?H $$ (i, a))"
        then have "?H $$ (nn, a) = H $$ (nn, a)  ?H $$ (nn, a)  res (?H $$ (i, a))"
            by presburger
          then have "¬ nn < i  ?H $$ (nn, LEAST n. ?H $$ (i, n)  0)  res (?H $$ (i, LEAST n. ?H $$ (i, n)  0))"
            using ff2 ff1 a_def order.strict_trans by blast }
        ultimately have "¬ nn < i  ?H $$ (nn, LEAST n. ?H $$ (i, n)  0)  res (?H $$ (i, LEAST n. ?H $$ (i, n)  0))"
          using Hermite_JNF_def a_eq assms(1) assms(2) im not'_iH by blast }
      then show ?thesis
        by meson
    qed
  qed
  show ?thesis using HNF1 HNF2 ef_H' CS_res CS_ass unfolding Hermite_JNF_def by blast
qed

lemma HNF_of_HNF_id:
  fixes H :: "int mat"
  assumes HNF_H: "Hermite_JNF associates res H"
  and H: "H  carrier_mat n n"
  and H_P1_H1: "H = P1 * H1"
  and inv_P1: "invertible_mat P1"
  and H1: "H1  carrier_mat n n" 
  and P1: "P1  carrier_mat n n"
  and HNF_H1: "Hermite_JNF associates res H1"
  and inv_H: "invertible_mat (map_mat rat_of_int H)"
  shows "H1 = H" 
proof (rule HNF_unique_generalized_JNF[OF H P1 H1 _ H H_P1_H1])   
  show "H = (1m n) * H" using H by auto  
qed (insert assms, auto)


(*Some of the following lemmas could be moved outside this context*)

context
  fixes n :: nat
begin

interpretation vec_module "TYPE(int)" .        

lemma lattice_is_monotone:
  fixes S T
  assumes S: "set S  carrier_vec n"
  assumes T: "set T  carrier_vec n"
  assumes subs: "set S  set T"
  shows "lattice_of S  lattice_of T"
proof -
  have "fa. lincomb fa (set T) = lincomb f (set S)" for f
  proof -
    let ?f = "λi. if i  set T - set S then 0 else f i"
    have set_T_eq: "set T = set S  (set T - set S)" using subs by blast
    have l0: "lincomb ?f (set T - set S) = 0v n" by (rule lincomb_zero, insert T, auto)
    have "lincomb ?f (set T) = lincomb ?f (set S  (set T - set S))" using set_T_eq by simp
    also have "... = lincomb ?f (set S) + lincomb ?f (set T - set S)"
      by (rule lincomb_union, insert S T subs, auto)
    also have "... = lincomb ?f (set S)" using l0 by (auto simp add: S)
    also have "... = lincomb f (set S)" using S by fastforce
    finally show ?thesis by blast    
  qed
  thus ?thesis unfolding lattice_of_altdef_lincomb[OF S] lattice_of_altdef_lincomb[OF T]
    by auto
qed

lemma lattice_of_append:
  assumes fs: "set fs  carrier_vec n"
  assumes gs: "set gs  carrier_vec n" 
  shows "lattice_of (fs @ gs) = lattice_of (gs @ fs)"
proof -
  have fsgs: "set (fs @ gs)  carrier_vec n" using fs gs by auto
  have gsfs: "set (gs @ fs)  carrier_vec n" using fs gs by auto
  show ?thesis
    unfolding lattice_of_altdef_lincomb[OF fsgs] lattice_of_altdef_lincomb[OF gsfs] 
    by auto (metis Un_commute)+
qed

lemma lattice_of_append_cons:
  assumes fs: "set fs  carrier_vec n"   and v: "v  carrier_vec n"
  shows "lattice_of (v # fs) = lattice_of (fs @ [v])"
proof -
  have v_fs: "set (v # fs)  carrier_vec n" using fs v by auto
  hence fs_v: "set (fs @ [v])  carrier_vec n" by simp
  show ?thesis
    unfolding lattice_of_altdef_lincomb[OF v_fs] lattice_of_altdef_lincomb[OF fs_v] by auto
qed

lemma already_in_lattice_subset:
  assumes fs: "set fs  carrier_vec n" and inlattice: "v  lattice_of fs"
  and v: "v  carrier_vec n"
  shows "lattice_of (v # fs)  lattice_of fs"
proof (cases "vset fs")
  case True
  then show ?thesis
    by (metis fs lattice_is_monotone set_ConsD subset_code(1))
next
  case False note v_notin_fs = False  
  obtain g where v_g: "lincomb g (set fs) = v"
    using lattice_of_altdef_lincomb[OF fs] inlattice by auto
  have v_fs: "set (v # fs)  carrier_vec n" using v fs by auto
  have "fa. lincomb fa (set fs) = lincomb f (insert v (set fs))" for f
  proof -
    have smult_rw: "f v v (lincomb g (set fs)) = lincomb (λw. f v * g w) (set fs)" 
      by (rule lincomb_smult[symmetric, OF fs])
    have "lincomb f (insert v (set fs)) =  f v v v + lincomb f (set fs)" 
      by (rule lincomb_insert2[OF _ fs _ v_notin_fs v], auto)
    also have "... = f v v (lincomb g (set fs)) + lincomb f (set fs)" using v_g by simp
    also have "... = lincomb (λw. f v * g w) (set fs)  + lincomb f (set fs)"
      unfolding smult_rw by auto
    also have "... = lincomb (λw. (λw. f v * g w) w + f w) (set fs)"
      by (rule lincomb_sum[symmetric, OF _ fs], simp)
    finally show ?thesis by auto
  qed
  thus ?thesis unfolding lattice_of_altdef_lincomb[OF v_fs] lattice_of_altdef_lincomb[OF fs] by auto
qed


lemma already_in_lattice:
  assumes fs: "set fs  carrier_vec n" and inlattice: "v  lattice_of fs"
  and v: "v  carrier_vec n"
  shows "lattice_of fs = lattice_of (v # fs)"
proof - 
  have dir1: "lattice_of fs  lattice_of (v # fs)"
    by (intro lattice_is_monotone, insert fs v, auto)
  moreover have dir2: "lattice_of (v # fs)  lattice_of fs"
    by (rule already_in_lattice_subset[OF assms])
  ultimately show ?thesis by auto
qed


lemma already_in_lattice_append:
  assumes fs: "set fs  carrier_vec n" and inlattice: "lattice_of gs  lattice_of fs"
  and gs: "set gs  carrier_vec n"
shows "lattice_of fs = lattice_of (fs @ gs)"
  using assms
proof (induct gs arbitrary: fs)
  case Nil
  then show ?case by auto
next
  case (Cons a gs)
  note fs = Cons.prems(1)
  note inlattice = Cons.prems(2)
  note gs = Cons.prems(3)
  have gs_in_fs: "lattice_of gs  lattice_of fs"
    by (meson basic_trans_rules(23) gs lattice_is_monotone local.Cons(3) set_subset_Cons)
  have a: "a  lattice_of (fs @ gs)"
    using basis_in_latticeI fs gs gs_in_fs local.Cons(1) local.Cons(3) by auto
  have "lattice_of (fs @ a # gs) = lattice_of ((a # gs) @ fs)"
    by (rule lattice_of_append, insert fs gs, auto) 
  also have "... = lattice_of (a # (gs @ fs))" by auto
  also have "... = lattice_of (a # (fs @ gs))"
    by (rule lattice_of_eq_set, insert gs fs, auto)
  also have "... = lattice_of (fs @ gs)"
    by (rule already_in_lattice[symmetric, OF _ a], insert fs gs, auto)
  also have "... = lattice_of fs" by (rule Cons.hyps[symmetric, OF fs gs_in_fs], insert gs, auto)     
  finally show ?case ..
qed

lemma zero_in_lattice:
  assumes fs_carrier: "set fs  carrier_vec n"
  shows "0v n  lattice_of fs"
proof - 
  have "f. lincomb (λv. 0 * f v) (set fs) = 0v n"
      using fs_carrier lincomb_closed lincomb_smult lmult_0 by presburger
  hence "lincomb (λi. 0) (set fs) = 0v n" by fastforce 
  thus ?thesis unfolding lattice_of_altdef_lincomb[OF fs_carrier] by auto
qed


lemma lattice_zero_rows_subset:
  assumes H: "H  carrier_mat a n"
  shows "lattice_of (Matrix.rows (0m m n))  lattice_of (Matrix.rows H)"
proof 
  let ?fs = "Matrix.rows (0m m n)"
  let ?gs = "Matrix.rows H"
  have fs_carrier: "set ?fs  carrier_vec n" unfolding Matrix.rows_def by auto
  have gs_carrier: "set ?gs  carrier_vec n" using H unfolding Matrix.rows_def by auto
  fix x assume x: "x  lattice_of (Matrix.rows (0m m n))"
  obtain f where fx: "lincomb (of_int  f) (set (Matrix.rows (0m m n))) = x"
    using x lattice_of_altdef_lincomb[OF fs_carrier] by blast
  have "lincomb (of_int  f) (set (Matrix.rows (0m m n))) = 0v n"
    unfolding lincomb_def by (rule M.finsum_all0, unfold Matrix.rows_def, auto)
  hence "x = 0v n" using fx by auto
  thus "x  lattice_of (Matrix.rows H)" using zero_in_lattice[OF gs_carrier] by auto 
qed

(*TODO: move outside this context (the previous lemmas too)*)
lemma lattice_of_append_zero_rows:
  assumes H': "H'  carrier_mat m n"
  and H: "H = H' @r (0m m n)"
shows "lattice_of (Matrix.rows H) = lattice_of (Matrix.rows H')"
proof -
  have "Matrix.rows H = Matrix.rows H' @ Matrix.rows (0m m n)"
    by (unfold H, rule rows_append_rows[OF H'], auto)
  also have "lattice_of ... = lattice_of (Matrix.rows H')"
  proof (rule already_in_lattice_append[symmetric])
    show "lattice_of (Matrix.rows (0m m n))  lattice_of (Matrix.rows H')"
      by (rule lattice_zero_rows_subset[OF H'])
  qed (insert H', auto simp add: Matrix.rows_def)
  finally show ?thesis .
qed
end

text ‹Lemmas about echelon form›

lemma echelon_form_JNF_1xn:
  assumes "Acarrier_mat m n" and "m<2"  
shows "echelon_form_JNF A"
  using assms unfolding echelon_form_JNF_def is_zero_row_JNF_def by fastforce


lemma echelon_form_JNF_mx1:
  assumes "Acarrier_mat m n" and "n<2"
  and "i  {1..<m}. A$$(i,0) = 0"
shows "echelon_form_JNF A"
  using assms unfolding echelon_form_JNF_def is_zero_row_JNF_def
    using atLeastLessThan_iff less_2_cases by fastforce


lemma echelon_form_mx0:
  assumes "A  carrier_mat m 0"
  shows "echelon_form_JNF A" using assms unfolding echelon_form_JNF_def is_zero_row_JNF_def by auto

lemma echelon_form_JNF_first_column_0:
  assumes eA: "echelon_form_JNF A" and A: "A  carrier_mat m n"
    and i0: "0<i" and im: "i<m" and n0: "0<n"
  shows "A $$ (i,0) =0"
proof (rule ccontr)
  assume Ai0: "A $$ (i, 0)  0"
  hence nz_iA:  "¬ is_zero_row_JNF i A" using n0 A unfolding is_zero_row_JNF_def by auto
  hence nz_0A: "¬ is_zero_row_JNF 0 A" using eA A unfolding echelon_form_JNF_def using i0 im by auto
  have "(LEAST n. A $$ (0, n)  0) < (LEAST n. A $$ (i, n)  0)"
    using nz_iA nz_0A eA A unfolding echelon_form_JNF_def using i0 im by blast
  moreover have "(LEAST n. A $$ (i, n)  0) = 0" using Ai0 by simp
  ultimately show False by auto
qed


lemma is_zero_row_JNF_multrow[simp]: 
  fixes A::"'a::comm_ring_1 mat"
  assumes "i<dim_row A"
  shows "is_zero_row_JNF i (multrow j (- 1) A) = is_zero_row_JNF i A"
  using assms unfolding is_zero_row_JNF_def by auto

lemma echelon_form_JNF_multrow:
  assumes "A : carrier_mat m n" and "i<m" and eA: "echelon_form_JNF A"
  shows "echelon_form_JNF (multrow i (- 1) A)"
proof (rule echelon_form_JNF_intro)
  have "A $$ (j, ja) = 0" if  "j'<dim_col A. A $$ (ia, j') = 0" 
    and iaj: "ia < j" and j: "j < dim_row A" and ja: "ja < dim_col A" for ia j ja
    using assms that unfolding echelon_form_JNF_def is_zero_row_JNF_def 
    by (meson order.strict_trans) 
  thus " ia<dim_row (multrow i (- 1) A). is_zero_row_JNF ia (multrow i (- 1) A) 
       ¬ (j<dim_row (multrow i (- 1) A). ia < j  ¬ is_zero_row_JNF j (multrow i (- 1) A))"
    unfolding is_zero_row_JNF_def by simp 
  have Least_eq: "(LEAST n. multrow i (- 1) A $$ (ia, n)  0) = (LEAST n. A $$ (ia, n)  0)"
    if ia: "ia < dim_row A" and nz_ia_mrA: "¬ is_zero_row_JNF ia (multrow i (- 1) A)" for ia
  proof (rule Least_equality)
    have nz_ia_A: "¬ is_zero_row_JNF ia A" using nz_ia_mrA ia by auto
    have Least_Aian_n: "(LEAST n. A $$ (ia, n)  0) < dim_col A"
      by (smt dual_order.strict_trans is_zero_row_JNF_def not_less_Least not_less_iff_gr_or_eq nz_ia_A)
    show "multrow i (- 1) A $$ (ia, LEAST n. A $$ (ia, n)  0)  0"
      by (smt LeastI Least_Aian_n class_cring.cring_simprules(22) equation_minus_iff ia
          index_mat_multrow(1) is_zero_row_JNF_def mult_minus1 nz_ia_A)
    show " y. multrow i (- 1) A $$ (ia, y)  0  (LEAST n. A $$ (ia, n)  0)  y"
      by (metis (mono_tags, lifting) Least_Aian_n class_cring.cring_simprules(22) ia 
          index_mat_multrow(1) leI mult_minus1 order.strict_trans wellorder_Least_lemma(2))
  qed
  have "(LEAST n. multrow i (- 1) A $$ (ia, n)  0) < (LEAST n. multrow i (- 1) A $$ (j, n)  0)"
    if ia_j: "ia < j" and
      j: "j < dim_row A"
      and nz_ia_A: "¬ is_zero_row_JNF ia A"
      and nz_j_A: "¬ is_zero_row_JNF j A"
    for ia j
  proof -
    have ia: "ia < dim_row A" using ia_j j by auto
    show ?thesis using Least_eq[OF ia] Least_eq[OF j] nz_ia_A nz_j_A 
        is_zero_row_JNF_multrow[OF ia] is_zero_row_JNF_multrow[OF j] eA ia_j j
      unfolding echelon_form_JNF_def by simp
  qed 
  thus "ia j.
       ia < j  j < dim_row (multrow i (- 1) A)  ¬ is_zero_row_JNF ia (multrow i (- 1) A)
         ¬ is_zero_row_JNF j (multrow i (- 1) A) 
       (LEAST n. multrow i (- 1) A $$ (ia, n)  0) < (LEAST n. multrow i (- 1) A $$ (j, n)  0)"
    by auto 
qed


(*The following lemma is already in HOL Analysis (thm echelon_form_imp_upper_triagular),
but only for square matrices. We prove it here for rectangular matrices.*)
thm echelon_form_imp_upper_triagular

(*First we prove an auxiliary statement*)
lemma echelon_form_JNF_least_position_ge_diagonal:
  assumes eA: "echelon_form_JNF A" 
  and A: "A: carrier_mat m n"
  and nz_iA: "¬ is_zero_row_JNF i A"
  and im: "i<m"
shows "i(LEAST n. A $$ (i,n)  0)"
  using nz_iA im
proof (induct i rule: less_induct)
  case (less i)
  note nz_iA = less.prems(1) 
  note im = less.prems(2)
  show ?case
  proof (cases "i=0")
    case True show ?thesis using True by blast
  next
    case False
    show ?thesis
    proof (rule ccontr)
      assume " ¬ i  (LEAST n. A $$ (i, n)  0)"
      hence i_least: "i > (LEAST n. A $$ (i, n)  0)" by auto
      have nz_i1A: "¬ is_zero_row_JNF (i-1) A" 
        using nz_iA im False A eA unfolding echelon_form_JNF_def
        by (metis Num.numeral_nat(7) Suc_pred carrier_matD(1) gr_implies_not0 
            lessI linorder_neqE_nat order.strict_trans)  
      have "i-1(LEAST n. A $$ (i-1,n)  0)" by (rule less.hyps, insert im nz_i1A False, auto)
      moreover have "(LEAST n. A $$ (i,n)  0) > (LEAST n. A $$ (i-1,n)  0)"
        using nz_i1A nz_iA im False A eA unfolding echelon_form_JNF_def by auto   
      ultimately show False using i_least by auto
    qed
  qed
qed


lemma echelon_form_JNF_imp_upper_triangular:
  assumes eA: "echelon_form_JNF A" 
  shows "upper_triangular A"
proof
  fix i j assume ji: "j<i" and i: "i<dim_row A"
  have A: "A  carrier_mat (dim_row A) (dim_col A)" by auto
  show "A $$ (i,j) = 0"
  proof (cases "is_zero_row_JNF i A")
    case False
    have "i (LEAST n. A $$(i,n)  0)"
      by (rule echelon_form_JNF_least_position_ge_diagonal[OF eA A False i])
    then show ?thesis 
      using ji not_less_Least order.strict_trans2 by blast
  next
    case True
      (*
    Problem detected: at this point, we don't know if j < dim_col A. 
    That is, upper_triangular definition only works for matrices ∈ carrier_mat m n with n≥m.
    The definition is: 
       - upper_triangular A ≡ ∀i < dim_row A. ∀ j < i. A $$ (i,j) = 0
     But we need here:
       - upper_triangular A ≡ ∀i < dim_row A. ∀ j < dim_col A. j < i  ⟶ A $$ (i,j) = 0
  
    Anyway, the existing definition makes sense since upper triangular is usually 
    restricted to square matrices.
  *)
    then show ?thesis unfolding is_zero_row_JNF_def oops


(*We do the same with the new definition upper_triangular'*)
lemma echelon_form_JNF_imp_upper_triangular:
  assumes eA: "echelon_form_JNF A" 
  shows "upper_triangular' A"
proof
  fix i j assume ji: "j<i" and i: "i<dim_row A" and j: "j<dim_col A"
  have A: "A  carrier_mat (dim_row A) (dim_col A)" by auto
  show "A $$ (i,j) = 0"
  proof (cases "is_zero_row_JNF i A")
    case False
    have "i (LEAST n. A $$(i,n)  0)"
      by (rule echelon_form_JNF_least_position_ge_diagonal[OF eA A False i])
    then show ?thesis 
      using ji not_less_Least order.strict_trans2 by blast
  next
    case True     
    then show ?thesis unfolding is_zero_row_JNF_def using j by auto
  qed
qed


lemma upper_triangular_append_zero:
  assumes uH: "upper_triangular' H" 
  and H: "H  carrier_mat (m+m) n" and mn: "nm"
  shows "H = mat_of_rows n (map (Matrix.row H) [0..<m]) @r 0m m n" (is "_ = ?H' @r 0m m n")
proof 
  have H': "?H'  carrier_mat m n" using H uH by auto
  have H'0: "(?H' @r 0m m n)  carrier_mat (m+m) n" by (simp add: H')
  thus dr: "dim_row H = dim_row (?H' @r 0m m n)" using H H'  by (simp add: append_rows_def) 
  show dc: "dim_col H = dim_col (?H' @r 0m m n)" using H H'  by (simp add: append_rows_def) 
  fix i j assume i: "i < dim_row (?H' @r 0m m n)" and j: "j < dim_col (?H' @r 0m m n)"
  show "H $$ (i, j) = (?H' @r 0m m n) $$ (i, j)"
  proof (cases "i<m")
    case True
    have "H $$ (i, j) = ?H' $$ (i,j)"
      by (metis True H' append_rows_def H carrier_matD index_mat_four_block(3) index_zero_mat(3) j 
          le_add1 map_first_rows_index mat_of_rows_carrier(2) mat_of_rows_index nat_arith.rule0)
    then show ?thesis
      by (metis (mono_tags, lifting) H' True add.comm_neutral append_rows_def 
          carrier_matD(1) i index_mat_four_block index_zero_mat(3) j)
  next
    case False 
    have imn: "i<m+m" using i dr H by auto
    have jn: "j<n" using j dc H by auto
    have ji: "j<i" using j i False mn jn by linarith
    hence "H $$ (i, j) = 0" using uH unfolding upper_triangular'_def dr imn using i jn 
      by (simp add: dc j)
    also have "... = (?H' @r 0m m n) $$ (i, j)"
      by (smt False H' append_rows_def assms(2) carrier_matD(1) carrier_matD(2) dc imn
          index_mat_four_block(1,3) index_zero_mat j less_diff_conv2 linorder_not_less)
    finally show ?thesis .
  qed
qed

subsubsection ‹The algorithm is sound›

lemma find_fst_non0_in_row: 
  assumes A: "A  carrier_mat m n"
  and res: "find_fst_non0_in_row l A = Some j"
  shows "A $$ (l,j)  0" "l  j" "j < dim_col A"
proof -
  let ?xs = "filter (λj. A $$ (l, j)  0) [l ..< dim_col A]"
  from res[unfolded find_fst_non0_in_row_def Let_def]
  have xs: "?xs  []" by (cases ?xs, auto)
  have j_in_xs: "j  set ?xs" using res unfolding find_fst_non0_in_row_def Let_def
    by (metis (no_types, lifting) length_greater_0_conv list.case(2) list.exhaust nth_mem option.simps(1) xs)
  show "A $$ (l,j)  0" "l  j" "j < dim_col A" using j_in_xs by auto+  
qed


lemma find_fst_non0_in_row_zero_before: 
  assumes A: "A  carrier_mat m n"
  and res: "find_fst_non0_in_row l A = Some j"
  shows "j'{l..<j}. A $$ (l,j') = 0"
proof -
  let ?xs = "filter (λj. A $$ (l, j)  0) [l ..< dim_col A]"
  from res[unfolded find_fst_non0_in_row_def Let_def]
  have xs: "?xs  []" by (cases ?xs, auto)
  have j_in_xs: "j  set ?xs" using res unfolding find_fst_non0_in_row_def Let_def
    by (metis (no_types, lifting) length_greater_0_conv list.case(2) list.exhaust nth_mem option.simps(1) xs)
  have j_xs0: "j = ?xs ! 0"
    by (smt res[unfolded find_fst_non0_in_row_def Let_def] list.case(2) list.exhaust option.inject xs)
  show "j'{l..<j}. A $$ (l,j') = 0"
  proof (rule+, rule ccontr)
    fix j' assume j': "j' : {l..<j}" and Alj': "A $$ (l, j')  0"
    have j'j: "j'<j" using j' by auto
    have j'_in_xs: "j'  set ?xs"
      by (metis (mono_tags, lifting) A Set.member_filter j' Alj' res atLeastLessThan_iff filter_set
          find_fst_non0_in_row(3) nat_SN.gt_trans set_upt)  
    have l_rw: "[l..<dim_col A] = [l ..<j] @[j..<dim_col A]"
      using assms(1) assms(2) find_fst_non0_in_row(3) j' upt_append by auto
    have xs_rw: "?xs = filter (λj. A $$ (l, j)  0) ([l ..<j] @[j..<dim_col A])"
      using l_rw by auto
    hence "filter (λj. A $$ (l, j)  0) [l ..<j] = []" using j_xs0 
      by (metis (no_types, lifting) Set.member_filter atLeastLessThan_iff filter_append filter_set
          length_greater_0_conv nth_append nth_mem order_less_irrefl set_upt)
    thus False using j_xs0 j' j_xs0 
      by (metis Set.member_filter filter_empty_conv filter_set j'_in_xs set_upt)
  qed
qed


corollary find_fst_non0_in_row_zero_before': 
  assumes A: "A  carrier_mat m n"
  and res: "find_fst_non0_in_row l A = Some j"
  and "j'  {l..<j}"
  shows "A $$ (l,j') = 0" using find_fst_non0_in_row_zero_before assms by auto

lemma find_fst_non0_in_row_LEAST: 
  assumes A: "A  carrier_mat m n"
  and ut_A: "upper_triangular' A"
  and res: "find_fst_non0_in_row l A = Some j"
  and lm: "l<m"
shows "j = (LEAST n. A $$ (l,n)  0)"
proof (rule Least_equality[symmetric])
  show " A $$ (l, j)  0" using res find_fst_non0_in_row(1) by blast
  show "y. A $$ (l, y)  0  j  y"
  proof (rule ccontr)
    fix y assume Aly: "A $$ (l, y)  0" and jy: " ¬ j  y "
    have yn: "y < n"
      by (metis A jy carrier_matD(2) find_fst_non0_in_row(3) leI less_imp_le_nat nat_SN.compat res)
    have "A $$(l,y) = 0"
    proof (cases "y{l..<j}")
      case True
      show ?thesis by (rule find_fst_non0_in_row_zero_before'[OF A res True])
    next
      case False hence "y<l" using jy by auto
      thus ?thesis using ut_A A lm unfolding upper_triangular'_def using yn by blast
    qed
    thus False using Aly by contradiction
  qed 
qed



lemma find_fst_non0_in_row_None': 
  assumes A: "A  carrier_mat m n"  
  and lm: "l<m"
shows "(find_fst_non0_in_row l A = None) = (j{l..<dim_col A}. A $$ (l,j) = 0)" (is "?lhs = ?rhs")
proof
  assume res: ?lhs
  let ?xs = "filter (λj. A $$ (l, j)  0) [l ..< dim_col A]"
  from res[unfolded find_fst_non0_in_row_def Let_def]
  have xs: "?xs = []" by (cases ?xs, auto)
  have "A $$ (l, j) = 0" if j: "j{l..<dim_col A}" for j
    using xs by (metis (mono_tags, lifting) empty_filter_conv j set_upt)
  thus "?rhs" by blast
next
  assume rhs: ?rhs
  show ?lhs
  proof (rule ccontr)
    assume "find_fst_non0_in_row l A  None" 
    from this obtain j where r: "find_fst_non0_in_row l A = Some j" by blast
    hence "A $$ (l,j)  0" and  "lj" and "j<dim_col A" using find_fst_non0_in_row[OF A r] by blast+
    thus False using rhs by auto  
  qed
qed


lemma find_fst_non0_in_row_None: 
  assumes A: "A  carrier_mat m n"
  and ut_A: "upper_triangular' A"
  and lm: "l<m"
shows "(find_fst_non0_in_row l A = None) = (is_zero_row_JNF l A)" (is "?lhs = ?rhs")
proof
  assume res: ?lhs
  let ?xs = "filter (λj. A $$ (l, j)  0) [l ..< dim_col A]"
  from res[unfolded find_fst_non0_in_row_def Let_def]
  have xs: "?xs = []" by (cases ?xs, auto)
  have "A $$ (l, j) = 0" if j: "j < dim_col A" for j
  proof (cases "j<l")
    case True
    then show ?thesis using ut_A A lm j unfolding upper_triangular'_def by blast
  next
    case False
    hence j_ln: "j  {l..<dim_col A}" using A lm j by simp
    then show ?thesis using xs by (metis (mono_tags, lifting) empty_filter_conv set_upt)
  qed
  thus "?rhs" unfolding is_zero_row_JNF_def by blast
next
  assume rhs: ?rhs
  show ?lhs
  proof (rule ccontr)
    assume "find_fst_non0_in_row l A  None" 
    from this obtain j where r: "find_fst_non0_in_row l A = Some j" by blast
    hence "A $$ (l,j)  0" and "j<dim_col A" using find_fst_non0_in_row[OF A r] by blast+
    hence "¬ is_zero_row_JNF l A" unfolding is_zero_row_JNF_def using lm A by auto
    thus False using rhs by contradiction    
  qed
qed

lemma make_first_column_positive_preserves_dimensions:
  shows [simp]: "dim_row (make_first_column_positive A) = dim_row A" 
    and [simp]: "dim_col (make_first_column_positive A) = dim_col A"
  by (auto)


lemma make_first_column_positive_works: 
  assumes "Acarrier_mat m n" and i: "i<m" and "0<n"
  shows "make_first_column_positive A $$ (i,0)  0"
  and "j<n  A $$ (i,0) < 0  (make_first_column_positive A) $$ (i,j) = - A $$ (i,j)"
  and "j<n  A $$ (i,0)  0  (make_first_column_positive A) $$ (i,j) = A $$ (i,j)"
  using assms by auto 


lemma make_first_column_positive_invertible: 
  shows  "P. invertible_mat P  P  carrier_mat (dim_row A) (dim_row A) 
   make_first_column_positive A = P * A" 
proof -
  let ?P = "Matrix.mat (dim_row A) (dim_row A)
          (λ(i,j). if i = j then if A $$(i,0) < 0 then - 1 else 1 else 0::int)"
  have "invertible_mat ?P"
  proof -
    have "(map abs (diag_mat ?P)) = replicate (length ((map abs (diag_mat ?P)))) 1" 
      by (rule replicate_length_same[symmetric], auto simp add: diag_mat_def)
    hence m_rw: "(map abs (diag_mat ?P)) = replicate (dim_row A) 1" by (auto simp add: diag_mat_def)
    have "Determinant.det ?P = prod_list (diag_mat ?P)" by (rule det_upper_triangular, auto)
    also have "abs ... = prod_list (map abs (diag_mat ?P))" unfolding prod_list_abs by blast
    also have " ... = prod_list (replicate (dim_row A) 1)" using m_rw by simp
    also have "... = 1" by auto
    finally have "¦Determinant.det ?P¦ = 1" by blast
    hence "Determinant.det ?P dvd 1" by fastforce
    thus ?thesis using invertible_iff_is_unit_JNF mat_carrier by blast (*Thanks to the new bridge*)
  qed    
  moreover have "make_first_column_positive A = ?P * A" (is "?M = _")
  proof (rule eq_matI)
    show "dim_row ?M = dim_row (?P * A)" and "dim_col ?M = dim_col (?P * A)" by auto
    fix i j assume i: "i < dim_row (?P * A)" and j: "j < dim_col (?P * A)"
    have set_rw: "{0..<dim_row A} = insert i ({0..<dim_row A} - {i})" using i by auto
      have rw0: "(ia  {0..<dim_row A } - {i}. Matrix.row ?P i $v ia * col A j $v ia) = 0"
        by (rule sum.neutral, insert i, auto)        
    have "(?P * A) $$ (i, j) = Matrix.row ?P i  col A j" using i j by auto
    also have "... = (ia = 0..<dim_row A. Matrix.row ?P i $v ia * col A j $v ia)"
        unfolding scalar_prod_def by auto
      also have "... =  (ia  insert i ({0..<dim_row A} - {i}). Matrix.row ?P i $v ia * col A j $v ia)"
        using set_rw by argo
      also have "... = Matrix.row ?P i $v i * col A j $v i 
        + (ia  {0..<dim_row A } - {i}. Matrix.row ?P i $v ia * col A j $v ia)" 
        by (rule sum.insert, auto)
      also have "... = Matrix.row ?P i $v i * col A j $v i" unfolding rw0 by simp
      finally have *: "(?P * A) $$ (i, j) = Matrix.row ?P i $v i * col A j $v i" .
    also have "... = ?M $$ (i,j)" 
      by (cases " A $$ (i, 0) < 0", insert i j, auto simp add: col_def)
    finally show "?M $$ (i, j) = (?P * A) $$ (i, j)" ..
  qed
  moreover have "?P  carrier_mat (dim_row A) (dim_row A)" by auto
  ultimately show ?thesis by blast
qed

locale proper_mod_operation = mod_operation +
  assumes dvd_gdiv_mult_right[simp]: "b > 0  b dvd a  (a gdiv b) * b = a"
    and gmod_gdiv: "y > 0  x gmod y = x - x gdiv y * y"
    and dvd_imp_gmod_0: "0 < a  a dvd b  b gmod a = 0" 
    and gmod_0_imp_dvd: "a gmod b = 0  b dvd a" 
    and gmod_0[simp]: "n gmod 0 = n" "n > 0  0 gmod n = 0"
begin
lemma reduce_alt_def_not0: 
  assumes "A $$ (a,0)  0" and pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A $$ (b,0))"
  shows "reduce a b D A =
       Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a then let r = (p*A$$(a,k) + q*A$$(b,k)) in
                              if k = 0 then if D dvd r then D else r else r gmod D
                   else if i = b then let r = u * A$$(a,k) + v * A$$(b,k) in
                              if k = 0 then r else r gmod D
                   else A$$(i,k))" (is "_ = ?rhs")
  and 
   "reduce_abs a b D A =
       Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a then let r = (p*A$$(a,k) + q*A$$(b,k)) in
                              if abs r > D then if k = 0  D dvd r then D else r gmod D else r 
                   else if i = b then let r = u * A$$(a,k) + v * A$$(b,k) in
                              if abs r > D then r gmod D else r
                   else A$$(i,k))" (is "_ = ?rhs_abs")
proof -
  have "reduce a b D A =
       (case euclid_ext2 (A$$(a,0)) (A $$ (b,0)) of (p,q,u,v,d) 
       Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a then let r = (p*A$$(a,k) + q*A$$(b,k)) in
                               if k = 0 then if D dvd r then D else r else r gmod D
                   else if i = b then let r = u * A$$(a,k) + v * A$$(b,k) in
                                if k = 0 then r else r gmod D
                   else A$$(i,k)
            ))" using assms by auto
  also have "... = ?rhs" unfolding reduce.simps Let_def 
    by (rule eq_matI, insert pquvd) (metis (no_types, lifting) split_conv)+
  finally show "reduce a b D A = ?rhs" .
  have "reduce_abs a b D A =
       (case euclid_ext2 (A$$(a,0)) (A $$ (b,0)) of (p,q,u,v,d) 
       Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a then let r = (p*A$$(a,k) + q*A$$(b,k)) in
                               if abs r > D then if k = 0  D dvd r then D else r gmod D else r 
                   else if i = b then let r = u * A$$(a,k) + v * A$$(b,k) in
                               if abs r > D then r gmod D else r
                   else A$$(i,k)
            ))" using assms by auto
  also have "... = ?rhs_abs" unfolding reduce.simps Let_def 
    by (rule eq_matI, insert pquvd) (metis (no_types, lifting) split_conv)+
  finally show "reduce_abs a b D A = ?rhs_abs" .
qed

lemma reduce_preserves_dimensions:
  shows [simp]: "dim_row (reduce a b D A) = dim_row A" 
    and [simp]: "dim_col (reduce a b D A) = dim_col A"
  and [simp]: "dim_row (reduce_abs a b D A) = dim_row A" 
    and [simp]: "dim_col (reduce_abs a b D A) = dim_col A"
  by (auto simp add: Let_def split_beta)

lemma reduce_carrier:
  assumes "A  carrier_mat m n"
  shows "(reduce a b D A)  carrier_mat m n" 
    and "(reduce_abs a b D A)  carrier_mat m n" 
  by (insert assms, auto simp add: Let_def split_beta)

lemma reduce_gcd: 
  assumes A: "A  carrier_mat m n" and a: "a<m" and j: "0<n" 
  and Aaj: "A $$ (a,0)  0"
shows "(reduce a b D A) $$ (a,0) = (let r = gcd (A$$(a,0)) (A$$(b,0)) in if D dvd r then D else r)" (is "?lhs = ?rhs")
  and "(reduce_abs a b D A) $$ (a,0) = (let r = gcd (A$$(a,0)) (A$$(b,0)) in if D < r then
                      if D dvd r then D else r gmod D else r)" (is "?lhs_abs = ?rhs_abs")
proof -
  obtain p q u v d where pquvd: "euclid_ext2 (A$$(a,0)) (A$$(b,0)) = (p,q,u,v,d)"
    using prod_cases5 by blast
  have "p * A $$ (a, 0) + q * A $$ (b, 0) = d" 
    using Aaj pquvd is_bezout_ext_euclid_ext2 unfolding is_bezout_ext_def 
    by (smt Pair_inject bezout_coefficients_fst_snd euclid_ext2_def)
  also have " ... = gcd (A$$(a,0)) (A$$(b,0))" by (metis euclid_ext2_def pquvd prod.sel(2))
  finally have pAaj_qAbj_gcd: "p * A $$ (a, 0) + q * A $$ (b, 0) = gcd (A$$(a,0)) (A$$(b,0))" .
  let ?f = "(λ(i, k). if i = a then let r = p * A $$ (a, k) + q * A $$ (b, k) in if k = 0 then if D dvd r then D else r else r gmod D
              else if i = b then let r = u * A $$ (a, k) + v * A $$ (b, k) in if k = 0 then r else r gmod D else A $$ (i, k))"
  have "(reduce a b D A) $$ (a,0) = Matrix.mat (dim_row A) (dim_col A) ?f $$ (a, 0)"
    using Aaj pquvd by auto 
  also have "... = (let r = p * A $$ (a, 0) + q * A $$ (b, 0) in if (0::nat) = 0 then if D dvd r then D else r else r gmod D)"
    using A a j by auto
  also have "... = (if D dvd gcd (A$$(a,0)) (A$$(b,0)) then D else 
      gcd (A$$(a,0)) (A$$(b,0)))" 
    by (simp add: pAaj_qAbj_gcd)
  finally show "?lhs = ?rhs" by auto
  let ?g = "(λ(i, k). if i = a then let r = p * A $$ (a, k) + q * A $$ (b, k) in 
                if D < ¦r¦ then if k = 0  D dvd r then D else r gmod D else r
              else if i = b then let r = u * A $$ (a, k) + v * A $$ (b, k) in 
                    if D < ¦r¦ then r gmod D else r else A $$ (i, k))"
  have "(reduce_abs a b D A) $$ (a,0) = Matrix.mat (dim_row A) (dim_col A) ?g $$ (a, 0)"
    using Aaj pquvd by auto 
  also have "... = (let r = p * A $$ (a, 0) + q * A $$ (b, 0) in if D < ¦r¦ then
            if (0::nat) = 0  D dvd r then D else r gmod D else r)"
    using A a j by auto
  also have "... = (if D < ¦gcd (A$$(a,0)) (A$$(b,0))¦ then if D dvd gcd (A$$(a,0)) (A$$(b,0)) then D else 
      gcd (A$$(a,0)) (A$$(b,0)) gmod D else gcd (A$$(a,0)) (A$$(b,0)))"
    by (simp add: pAaj_qAbj_gcd)
  finally show "?lhs_abs = ?rhs_abs" by auto
qed




lemma reduce_preserves: 
  assumes A: "A  carrier_mat m n" and j: "j<n" 
  and Aaj: "A $$ (a,0)  0" and ib: "ib" and ia: "ia" and im: "i<m"
shows "(reduce a b D A) $$ (i,j) = A $$ (i,j)"  (is "?thesis1")
and "(reduce_abs a b D A) $$ (i,j) = A $$ (i,j)" (is "?thesis2") 
proof -
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(b,0))"
    using prod_cases5 by metis
  show ?thesis1 unfolding reduce_alt_def_not0[OF Aaj pquvd] using ia im j A ib by auto
  show ?thesis2 unfolding reduce_alt_def_not0[OF Aaj pquvd] using ia im j A ib by auto
qed


lemma reduce_0: 
  assumes A: "A  carrier_mat m n" and a: "a<m" and j: "0<n" and b: "b<m" and ab: "a  b"
  and Aaj: "A $$ (a,0)  0"
  and D: "D  0" 
shows "(reduce a b D A) $$ (b,0) = 0" (is "?thesis1")
and "(reduce_abs a b D A) $$ (b,0) = 0" (is "?thesis2")
proof -
  obtain p q u v d where pquvd: "euclid_ext2 (A$$(a,0)) (A$$(b,0)) = (p,q,u,v,d)"
    using prod_cases5 by blast
  hence u: "u = - (A$$(b,0)) div gcd (A$$(a,0)) (A$$(b,0))"
    using euclid_ext2_works[OF pquvd] by auto
  have v: "v = A$$(a,0) div gcd (A$$(a,0)) (A$$(b,0))" using euclid_ext2_works[OF pquvd] by auto
  have uv0: "u * A$$(a,0) + v * A$$(b,0) = 0" using u v
  proof -
    have "i ia. gcd (ia::int) i * (ia div gcd ia i) = ia"
    by (meson dvd_mult_div_cancel gcd_dvd1)
    then have "v * - A $$ (b, 0) = u * A $$ (a, 0)"
      by (metis (no_types) dvd_minus_iff dvd_mult_div_cancel gcd_dvd2 minus_minus mult.assoc mult.commute u v)
    then show ?thesis
      by simp
  qed
  let ?f = "(λ(i, k). if i = a then let r = p * A $$ (a, k) + q * A $$ (b, k) in 
            if k = 0 then if D dvd r then D else r else r gmod D
              else if i = b then let r = u * A $$ (a, k) + v * A $$ (b, k) in 
                   if k = 0 then r else r gmod D else A $$ (i, k))" 
  have "(reduce a b D A) $$ (b,0) = Matrix.mat (dim_row A) (dim_col A) ?f $$ (b, 0)"
    using Aaj pquvd by auto 
  also have "... = (let r = u * A$$(a,0) + v * A$$(b,0) in r)"
    using A a j ab b by auto
  also have "... = 0" using uv0 D 
    by (smt (z3) gmod_0(1) gmod_0(2)) 
  finally show ?thesis1 .
  let ?g = "(λ(i, k). if i = a then let r = p * A $$ (a, k) + q * A $$ (b, k) in 
          if D < ¦r¦ then if k = 0  D dvd r then D else r gmod D else r
              else if i = b then let r = u * A $$ (a, k) + v * A $$ (b, k) in 
                  if D < ¦r¦ then r gmod D else r else A $$ (i, k))" 
  have "(reduce_abs a b D A) $$ (b,0) = Matrix.mat (dim_row A) (dim_col A) ?g $$ (b, 0)"
    using Aaj pquvd by auto 
  also have "... = (let r = u * A$$(a,0) + v * A$$(b,0) in if D < ¦r¦ then r gmod D else r)"
    using A a j ab b by auto
  also have "... = 0" using uv0 D by simp
  finally show ?thesis2 .
qed
end


text ‹Let us show the key lemma: operations modulo determinant don't modify the (integer) row span.›

context LLL_with_assms
begin

lemma lattice_of_kId_subset_fs_init: 
  assumes k_det: "k = Determinant.det (mat_of_rows n fs_init)"
  and mn: "m=n"
  shows "lattice_of (Matrix.rows (k m (1m m)))  lattice_of fs_init"
proof -
  let ?Z = "(mat_of_rows n fs_init)"
  let ?RAT = "of_int_hom.mat_hom :: int mat  rat mat"
  have RAT_fs_init: "?RAT (mat_of_rows n fs_init)  carrier_mat n n"
      using len map_carrier_mat mat_of_rows_carrier(1) mn by blast
  have det_RAT_fs_init: "Determinant.det (?RAT ?Z)  0"
  proof (rule gs.lin_indpt_rows_imp_det_not_0[OF RAT_fs_init])   
    have rw: "Matrix.rows (?RAT (mat_of_rows n fs_init)) = RAT fs_init"
      by (metis cof_vec_space.lin_indpt_list_def fs_init lin_dep mat_of_rows_map rows_mat_of_rows)
    thus "gs.lin_indpt (set (Matrix.rows (?RAT (mat_of_rows n fs_init))))" 
      by (insert lin_dep, simp add: cof_vec_space.lin_indpt_list_def)
    show "distinct (Matrix.rows (?RAT (mat_of_rows n fs_init)))"
      using rw cof_vec_space.lin_indpt_list_def lin_dep by auto
  qed
  obtain inv_Z where inverts_Z: "inverts_mat (?RAT ?Z) inv_Z" and inv_Z: "inv_Z  carrier_mat m m"
    by (metis mn det_RAT_fs_init dvd_field_iff invertible_iff_is_unit_JNF
        len map_carrier_mat mat_of_rows_carrier(1) obtain_inverse_matrix)
  have det_rat_Z_k: "Determinant.det (?RAT ?Z) = rat_of_int k"
    using k_det of_int_hom.hom_det by blast
  have "?RAT ?Z *  adj_mat (?RAT ?Z) = Determinant.det (?RAT ?Z) m 1m n" 
    by (rule adj_mat[OF RAT_fs_init])
  hence "inv_Z * (?RAT ?Z *  adj_mat (?RAT ?Z)) = inv_Z * (Determinant.det (?RAT ?Z) m 1m n)" by simp
  hence k_inv_Z_eq_adj: "(rat_of_int k) m inv_Z = adj_mat (?RAT ?Z)"
    by (smt Determinant.mat_mult_left_right_inverse RAT_fs_init adj_mat(1,3) mn 
        carrier_matD det_RAT_fs_init det_rat_Z_k gs.det_nonzero_congruence inv_Z inverts_Z 
        inverts_mat_def mult_smult_assoc_mat smult_carrier_mat)
  have adj_mat_Z: "adj_mat (?RAT ?Z) $$ (i,j)  " if i: "i<m" and j: "j<n" for i j
  proof -
    have det_mat_delete_Z: "Determinant.det (mat_delete (?RAT ?Z) j i)  "
    proof (rule Ints_det)
      fix ia ja
      assume ia: "ia < dim_row  (mat_delete (?RAT ?Z) j i)"
        and ja: "ja < dim_col  (mat_delete (?RAT ?Z) j i)"
      have "(mat_delete (?RAT ?Z) j i) $$ (ia, ja) =  (?RAT ?Z) $$ (insert_index j ia, insert_index i ja)"        
        by (rule mat_delete_index[symmetric], insert i j mn len ia ja RAT_fs_init, auto)
      also have "... = rat_of_int (?Z $$ (insert_index j ia, insert_index i ja))"
        by (rule index_map_mat, insert i j ia ja, auto simp add: insert_index_def)
      also have "...  " using Ints_of_int by blast
      finally show "(mat_delete (?RAT ?Z) j i) $$ (ia, ja)  " .
    qed
    have "adj_mat (?RAT ?Z) $$ (i,j) = Determinant.cofactor (?RAT ?Z) j i"
      unfolding adj_mat_def
      by (simp add: len i j)
    also have "... =  (- 1) ^ (j + i) * Determinant.det (mat_delete (?RAT ?Z) j i)"
      unfolding Determinant.cofactor_def by auto
    also have "...  " using det_mat_delete_Z by auto
    finally show ?thesis .
  qed                
  have kinvZ_in_Z: "((rat_of_int k) m inv_Z) $$ (i,j)  " if i: "i<m" and j: "j<n" for i j
    using k_inv_Z_eq_adj by (simp add: adj_mat_Z i j)
  have "?RAT (k m (1m m)) = Determinant.det (?RAT ?Z) m (inv_Z * ?RAT ?Z)" (is "?lhs = ?rhs")
  proof - 
    have "(inv_Z * ?RAT ?Z) = (1m m)"
      by (metis Determinant.mat_mult_left_right_inverse RAT_fs_init mn carrier_matD(1)
          inv_Z inverts_Z inverts_mat_def)
    from this have "?rhs = rat_of_int k m (1m m)" using det_rat_Z_k by auto
    also have "... = ?lhs" by auto
    finally show ?thesis ..
  qed
  also have "... = (Determinant.det (?RAT ?Z) m inv_Z) * ?RAT ?Z"
    by (metis RAT_fs_init mn inv_Z mult_smult_assoc_mat)
  also have "... = ((rat_of_int k) m inv_Z) * ?RAT ?Z" by (simp add: k_det)
  finally have r': "?RAT (k m (1m m)) = ((rat_of_int k) m inv_Z) * ?RAT ?Z" .
  have r: "(k m (1m m)) = ((map_mat int_of_rat ((rat_of_int k) m inv_Z))) * ?Z"
  proof -
    have "?RAT ((map_mat int_of_rat ((rat_of_int k) m inv_Z))) = ((rat_of_int k) m inv_Z)"
    proof (rule eq_matI, auto)
      fix i j assume i: "i < dim_row inv_Z" and j: "j < dim_col inv_Z"
      have "((rat_of_int k) m inv_Z) $$ (i,j) =  (rat_of_int k * inv_Z $$ (i, j))"
        using index_smult_mat i j by auto
      hence kinvZ_in_Z': "...  " using kinvZ_in_Z i j inv_Z mn by simp
      show "rat_of_int (int_of_rat (rat_of_int k * inv_Z $$ (i, j))) = rat_of_int k * inv_Z $$ (i, j)" 
        by (rule int_of_rat, insert kinvZ_in_Z', auto)
    qed
    hence "?RAT (k m (1m m)) = ?RAT ((map_mat int_of_rat ((rat_of_int k) m inv_Z))) * ?RAT ?Z"
      using r' by simp
    also have "... = ?RAT ((map_mat int_of_rat ((rat_of_int k) m inv_Z)) * ?Z)"
      by (metis RAT_fs_init adj_mat(1) k_inv_Z_eq_adj map_carrier_mat of_int_hom.mat_hom_mult)
    finally show ?thesis by (rule of_int_hom.mat_hom_inj)
  qed
  show ?thesis
  proof (rule mat_mult_sub_lattice[OF _ fs_init])
    have rw: "of_int_hom.mat_hom (map_mat int_of_rat ((rat_of_int k) m inv_Z)) 
      = map_mat int_of_rat ((rat_of_int k) m inv_Z)" by auto
    have "mat_of_rows n (Matrix.rows (k m 1m m)) = (k m (1m m))" 
      by (metis mn index_one_mat(3) index_smult_mat(3) mat_of_rows_rows)
    also have "... = of_int_hom.mat_hom (map_mat int_of_rat ((rat_of_int k) m inv_Z)) * mat_of_rows n fs_init" 
       using r rw by auto 
    finally show "mat_of_rows n (Matrix.rows (k m 1m m)) 
      = of_int_hom.mat_hom (map_mat int_of_rat ((rat_of_int k) m inv_Z)) * mat_of_rows n fs_init" .
   show "set (Matrix.rows (k m 1m m))  carrier_vec n"using mn unfolding Matrix.rows_def by auto
   show "map_mat int_of_rat (rat_of_int k m inv_Z)  carrier_mat (length (Matrix.rows (k m 1m m))) (length fs_init)"
     using len fs_init by (simp add: inv_Z)
  qed
qed

end

context LLL_with_assms
begin


lemma lattice_of_append_det_preserves:  
  assumes k_det: "k = abs (Determinant.det (mat_of_rows n fs_init))"
  and mn: "m = n"
  and A: "A = (mat_of_rows n fs_init) @r (k m (1m m))"
shows "lattice_of (Matrix.rows A) = lattice_of fs_init"
proof -
  have "Matrix.rows (mat_of_rows n fs_init @r k m 1m m) = (Matrix.rows (mat_of_rows n fs_init) @ Matrix.rows (k m (1m m)))"
    by (rule rows_append_rows, insert fs_init len mn, auto)
  also have "... = (fs_init @ Matrix.rows (k m (1m m)))" by (simp add: fs_init)
  finally have rw: "Matrix.rows (mat_of_rows n fs_init @r k m 1m m) 
    = (fs_init @ Matrix.rows (k m (1m m)))" .
  have "lattice_of (Matrix.rows A) = lattice_of (fs_init @ Matrix.rows (k m (1m m)))"
    by (rule arg_cong[of _ _ lattice_of], auto simp add: A rw)
  also have "... = lattice_of fs_init" 
  proof (cases "k = Determinant.det (mat_of_rows n fs_init)")
    case True
    then show ?thesis 
    by (rule already_in_lattice_append[symmetric, OF fs_init 
             lattice_of_kId_subset_fs_init[OF _ mn]], insert mn, auto simp add: Matrix.rows_def)
  next
    case False
    hence k2: "k = -Determinant.det (mat_of_rows n fs_init)" using k_det by auto
    have l: "lattice_of (Matrix.rows (- k m 1m m))  lattice_of fs_init"
      by (rule lattice_of_kId_subset_fs_init[OF _ mn], insert k2, auto)
    have l2: "lattice_of (Matrix.rows (- k m 1m m)) = lattice_of (Matrix.rows (k m 1m m))" 
    proof (rule mat_mult_invertible_lattice_eq)
      let ?P = "(- 1::int) m 1m m"
      show P: "?P  carrier_mat m m" by simp
      have "det ?P = 1  det ?P = -1" unfolding det_smult by (auto simp add: minus_1_power_even)
      hence "det ?P dvd 1" by (smt minus_dvd_iff one_dvd)
      thus " invertible_mat ?P" unfolding invertible_iff_is_unit_JNF[OF P] .
      have "(- k m 1m m) = ?P * (k m 1m m)"
        unfolding mat_diag_smult[symmetric] unfolding mat_diag_diag by auto
      thus " mat_of_rows n (Matrix.rows (- k m 1m m)) = of_int_hom.mat_hom ?P * mat_of_rows n (Matrix.rows (k m 1m m))"
        by (metis mn index_one_mat(3) index_smult_mat(3) mat_of_rows_rows of_int_mat_hom_int_id)
      show " set (Matrix.rows (- k m 1m m))  carrier_vec n"
        and "set (Matrix.rows (k m 1m m))  carrier_vec n"
        using assms(2) one_carrier_mat set_rows_carrier smult_carrier_mat by blast+
    qed (insert mn, auto)
    hence l2: "lattice_of (Matrix.rows (k m 1m m))  lattice_of fs_init" using l by auto
    show ?thesis by (rule already_in_lattice_append[symmetric, OF fs_init l2],
          insert mn one_carrier_mat set_rows_carrier smult_carrier_mat, blast)
  qed  
  finally show ?thesis .
qed

text ‹This is another key lemma.
Here, $A$ is the initial matrix @{text "(mat_of_rows n fs_init)"} augmented with $m$ rows 
$(k,0,\dots,0),(0,k,0,\dots,0), \dots , (0,\dots,0,k)$ where $k$ is the determinant of 
@{text "(mat_of_rows n fs_init)"}. 
With the algorithm of the article, we obtain @{text "H = H' @r (0m m n)"} by means of an invertible 
matrix $P$ (which is computable). Then, $H$ is the HNF of $A$.
The lemma shows that $H'$ is the HNF of @{text "(mat_of_rows n fs_init)"}
and that there exists an invertible matrix to carry out the transformation.›

lemma Hermite_append_det_id:
  assumes k_det: "k = abs (Determinant.det (mat_of_rows n fs_init))"
  and mn: "m = n"
  and A: "A = (mat_of_rows n fs_init) @r (k m (1m m))"
  and H': "H' carrier_mat m n"
  and H_append: "H = H' @r (0m m n)"
  and P: "P  carrier_mat (m+m) (m+m)"
  and inv_P: "invertible_mat P"
  and A_PH: "A = P * H"
  and HNF_H: "Hermite_JNF associates res H"
shows "Hermite_JNF associates res H'" 
  and "(P'. invertible_mat P'  P'  carrier_mat m m  (mat_of_rows n fs_init) = P' * H')"
proof -
  have A_carrier: "A  carrier_mat (m+m) n" using A mn len by auto
  let ?A' = "(mat_of_rows n fs_init)"
  let ?H' = "submatrix H {0..<m} {0..<n}"
  have nm: "nm" by (simp add: mn) 
  have H: "H  carrier_mat (m + m) n" using H_append H' by auto
  have submatrix_carrier: "submatrix H {0..<m} {0..<n}  carrier_mat m n"
    by (rule submatrix_carrier_first[OF H], auto)
  have H'_eq: "H' = ?H'"
  proof (rule eq_matI)
    fix i j assume i: "i < dim_row ?H'" and j: "j < dim_col ?H'"
    have im: "i<m" and jn: "j<n" using i j submatrix_carrier by auto
    have "?H' $$ (i,j) = H $$ (i,j)"
      by (rule submatrix_index_id[OF H], insert i j submatrix_carrier, auto)
    also have "... =  (if i < dim_row H' then H' $$ (i, j) else (0m m n) $$ (i - m, j))"
      unfolding H_append by (rule append_rows_nth[OF H'], insert im jn, auto)
    also have "... = H' $$ (i,j)" using H' im jn by simp
    finally show "H' $$ (i, j) = ?H' $$ (i, j)" ..
  qed (insert H' submatrix_carrier, auto)  
  show HNF_H': "Hermite_JNF associates res H'"
    unfolding H'_eq mn by (rule HNF_submatrix[OF HNF_H H], insert nm, simp)
  have L_fs_init_A: "lattice_of (fs_init) = lattice_of (Matrix.rows A)" 
    by (rule lattice_of_append_det_preserves[symmetric, OF k_det mn A])
  have L_H'_H: "lattice_of (Matrix.rows H') = lattice_of (Matrix.rows H)"
    using H_append H' lattice_of_append_zero_rows by blast
  have L_A_H: "lattice_of (Matrix.rows A) = lattice_of (Matrix.rows H)"
  proof (rule mat_mult_invertible_lattice_eq[OF _ _ P inv_P])
    show "set (Matrix.rows A)  carrier_vec n" using A_carrier set_rows_carrier by blast
    show "set (Matrix.rows H)  carrier_vec n" using H set_rows_carrier by blast
    show "length (Matrix.rows A) = m + m" using A_carrier by auto      
    show "length (Matrix.rows H) = m + m" using H by auto
    show "mat_of_rows n (Matrix.rows A) = of_int_hom.mat_hom P * mat_of_rows n (Matrix.rows H)"      
      by (metis A_carrier H A_PH carrier_matD(2) mat_of_rows_rows of_int_mat_hom_int_id)
  qed
  have L_fs_init_H': "lattice_of fs_init = lattice_of (Matrix.rows H')"
    using L_fs_init_A L_A_H L_H'_H by auto
  have exists_P2: 
      "P2. P2  carrier_mat n n  invertible_mat P2  mat_of_rows n  (Matrix.rows H') = P2 * H'"
    by (rule exI[of _ "1m n"], insert H' mn, auto)
  have exist_P': "P'carrier_mat n n. invertible_mat P' 
       mat_of_rows n fs_init = P' * mat_of_rows n (Matrix.rows H')"
    by (rule eq_lattice_imp_mat_mult_invertible_rows[OF fs_init _ lin_dep len[unfolded mn] _ L_fs_init_H'],
        insert H' mn set_rows_carrier, auto)
  thus "P'. invertible_mat P'  P'  carrier_mat m m  (mat_of_rows n fs_init) = P' * H'"
    by (metis mn H' carrier_matD(2) mat_of_rows_rows)
qed
end



context proper_mod_operation
begin

(* Perform the modulo D operation to reduce the element A$$(a,j), assuming A = A' @r  (D ⋅m (1m m))*)
definition "reduce_element_mod_D (A::int mat) a j D m =  
  (if j = 0 then if D dvd A$$(a,j) then addrow (-((A$$(a,j) gdiv D)) + 1) a (j + m) A else A
  else addrow (-((A$$(a,j) gdiv D))) a (j + m) A)"

definition "reduce_element_mod_D_abs (A::int mat) a j D m =  
  (if j = 0  D dvd A$$(a,j) then addrow (-((A$$(a,j) gdiv D)) + 1) a (j + m) A 
  else addrow (-((A$$(a,j) gdiv D))) a (j + m) A)"

lemma reduce_element_mod_D_preserves_dimensions:
  shows [simp]: "dim_row (reduce_element_mod_D A a j D m) = dim_row A" 
    and [simp]: "dim_col (reduce_element_mod_D A a j D m) = dim_col A"
    and [simp]: "dim_row (reduce_element_mod_D_abs A a j D m) = dim_row A" 
    and [simp]: "dim_col (reduce_element_mod_D_abs A a j D m) = dim_col A"
  by (auto simp add: reduce_element_mod_D_def reduce_element_mod_D_abs_def Let_def split_beta)

lemma reduce_element_mod_D_carrier:
  shows "reduce_element_mod_D A a j D m  carrier_mat (dim_row A) (dim_col A)" 
    and "reduce_element_mod_D_abs A a j D m  carrier_mat (dim_row A) (dim_col A)" by auto


lemma reduce_element_mod_D_invertible_mat:
  assumes A_def: "A = A' @r  (D m (1m n))"
    and A': "A'  carrier_mat m n" and a: "a<m" and j: "j<n" and mn: "mn"
  shows "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  
    reduce_element_mod_D A a j D m = P * A" (is ?thesis1)
    and "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  
    reduce_element_mod_D_abs A a j D m = P * A" (is ?thesis2)
  unfolding atomize_conj
proof (rule conjI; cases "j = 0  D dvd A$$(a,j)")
  case True
  let ?P = "addrow_mat (m+n) (- (A $$ (a, j) gdiv D) + 1) a (j + m)"
  have A: "A  carrier_mat (m + n) n" using A_def A' mn by auto
  have "reduce_element_mod_D A a j D m = addrow (- (A $$ (a, j) gdiv D) + 1) a (j + m) A"
    unfolding reduce_element_mod_D_def using True by auto
  also have "... = ?P * A" by (rule addrow_mat[OF A], insert j mn, auto)
  finally have "reduce_element_mod_D A a j D m = ?P * A" .
  moreover have P: "?P  carrier_mat (m+n) (m+n)" by simp
  moreover have inv_P: "invertible_mat ?P"
    by (metis addrow_mat_carrier a det_addrow_mat dvd_mult_right 
        invertible_iff_is_unit_JNF mult.right_neutral not_add_less2 semiring_gcd_class.gcd_dvd1)
  ultimately show ?thesis1 by blast
  have "reduce_element_mod_D_abs A a j D m = addrow (- (A $$ (a, j) gdiv D) + 1) a (j + m) A"
    unfolding reduce_element_mod_D_abs_def using True by auto
  also have "... = ?P * A" by (rule addrow_mat[OF A], insert j mn, auto)
  finally have "reduce_element_mod_D_abs A a j D m = ?P * A" .
  thus ?thesis2 using P inv_P by blast
next
  case False note nc1 = False
  let ?P = "addrow_mat (m+n) (- (A $$ (a, j) gdiv D)) a (j + m)"
  have A: "A  carrier_mat (m + n) n" using A_def A' mn by auto
  have P: "?P  carrier_mat (m+n) (m+n)" by simp
  have inv_P: "invertible_mat ?P"
    by (metis addrow_mat_carrier a det_addrow_mat dvd_mult_right 
        invertible_iff_is_unit_JNF mult.right_neutral not_add_less2 semiring_gcd_class.gcd_dvd1)
  show ?thesis1
  proof (cases "j = 0")
    case True
    have "reduce_element_mod_D A a j D m = A" 
      unfolding reduce_element_mod_D_def using True nc1 by auto
    thus ?thesis1
      by (metis A_def A' carrier_append_rows invertible_mat_one 
          left_mult_one_mat one_carrier_mat smult_carrier_mat)
  next
    case False   
    have "reduce_element_mod_D A a j D m =  addrow (- (A $$ (a, j) gdiv D)) a (j + m) A"
      unfolding reduce_element_mod_D_def using False by auto
    also have "... = ?P * A" by (rule addrow_mat[OF A], insert j mn, auto)
    finally have "reduce_element_mod_D A a j D m = ?P * A" .    
    thus ?thesis using P inv_P by blast
  qed
  have "reduce_element_mod_D_abs A a j D m =  addrow (- (A $$ (a, j) gdiv D)) a (j + m) A"
    unfolding reduce_element_mod_D_abs_def using False by auto
  also have "... = ?P * A" by (rule addrow_mat[OF A], insert j mn, auto)
  finally have "reduce_element_mod_D_abs A a j D m = ?P * A" .    
  thus ?thesis2 using P inv_P by blast
qed


lemma reduce_element_mod_D_append:
  assumes A_def: "A = A' @r  (D m (1m n))"
  and A': "A'  carrier_mat m n" and a: "a<m" and j: "j<n" and mn: "mn"
shows "reduce_element_mod_D A a j D m 
  = mat_of_rows n [Matrix.row (reduce_element_mod_D A a j D m) i. i  [0..<m]] @r (D m (1m n))" (is "?lhs = ?A' @r ?D")
and "reduce_element_mod_D_abs A a j D m 
  = mat_of_rows n [Matrix.row (reduce_element_mod_D_abs A a j D m) i. i  [0..<m]] @r (D m (1m n))" (is "?lhs_abs = ?A'_abs @r ?D")
  unfolding atomize_conj
proof (rule conjI; rule eq_matI)
  let ?xs = "(map (Matrix.row (reduce_element_mod_D A a j D m)) [0..<m])"
  let ?xs_abs = "(map (Matrix.row (reduce_element_mod_D_abs A a j D m)) [0..<m])"
  have lhs_carrier: "?lhs  carrier_mat (m+n) n"
    and lhs_carrier_abs: "?lhs_abs  carrier_mat (m+n) n"
    by (metis (no_types, lifting) add.comm_neutral append_rows_def A_def A' carrier_matD 
        carrier_mat_triv index_mat_four_block(2,3) index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3) 
        reduce_element_mod_D_preserves_dimensions)+
  have map_A_carrier[simp]: "?A'  carrier_mat m n" 
    and map_A_carrier_abs[simp]: "?A'_abs  carrier_mat m n"
    by (simp add: mat_of_rows_def)+
  have AD_carrier[simp]: "?A' @r ?D  carrier_mat (m+n) n" 
    and AD_carrier_abs[simp]: "?A'_abs @r ?D  carrier_mat (m+n) n" 
    by (rule carrier_append_rows, insert lhs_carrier mn, auto)
  show "dim_row (?lhs) = dim_row (?A' @r ?D)"  and "dim_col (?lhs) = dim_col (?A' @r ?D)"
    "dim_row (?lhs_abs) = dim_row (?A'_abs @r ?D)"  and "dim_col (?lhs_abs) = dim_col (?A'_abs @r ?D)"
    using lhs_carrier lhs_carrier_abs AD_carrier AD_carrier_abs unfolding carrier_mat_def by simp+
  show "?lhs $$ (i, ja) = (?A' @r ?D) $$ (i, ja)" if i: "i < dim_row (?A' @r ?D)" and ja: "ja < dim_col (?A' @r ?D)" for i ja
  proof (cases "i<m")
    case True
    have ja_n: "ja < n"
      by (metis Nat.add_0_right append_rows_def index_mat_four_block(3) index_zero_mat(3) ja mat_of_rows_carrier(3))
    have "(?A' @r ?D) $$ (i, ja) = ?A' $$ (i,ja)"
      by (metis (no_types, lifting) Nat.add_0_right True append_rows_def diff_zero i 
          index_mat_four_block index_zero_mat(3) ja length_map length_upt mat_of_rows_carrier(2))
    also have "... = ?xs ! i $v ja" 
      by (rule mat_of_rows_index, insert i True ja , auto simp add: append_rows_def)
    also have "... = ?lhs $$ (i,ja)"
      by (rule map_first_rows_index, insert assms lhs_carrier True i ja_n, auto)
    finally show ?thesis ..
  next
    case False
    have ja_n: "ja < n"
      by (metis Nat.add_0_right append_rows_def index_mat_four_block(3) index_zero_mat(3) ja mat_of_rows_carrier(3))
    have "(?A' @r ?D) $$ (i, ja) =?D $$ (i-m,ja)"
      by (smt False Nat.add_0_right map_A_carrier append_rows_def carrier_matD i 
          index_mat_four_block index_zero_mat(3) ja_n)
    also have "... = ?lhs $$ (i,ja)"
      by (metis (no_types, lifting) False Nat.add_0_right map_A_carrier append_rows_def A_def A' a 
          carrier_matD i index_mat_addrow(1) index_mat_four_block(1,2) index_zero_mat(3) ja_n 
          lhs_carrier reduce_element_mod_D_def reduce_element_mod_D_preserves_dimensions)
    finally show ?thesis ..
  qed
  fix i ja assume i: "i < dim_row (?A'_abs @r ?D)" and ja: "ja < dim_col (?A'_abs @r ?D)"
  have ja_n: "ja < n"
    by (metis Nat.add_0_right append_rows_def index_mat_four_block(3) index_zero_mat(3) ja mat_of_rows_carrier(3))
  show "?lhs_abs $$ (i, ja) = (?A'_abs @r ?D) $$ (i, ja)"
  proof (cases "i<m")
    case True
    have "(?A'_abs @r ?D) $$ (i, ja) = ?A'_abs $$ (i,ja)"
      by (metis (no_types, lifting) Nat.add_0_right True append_rows_def diff_zero i 
          index_mat_four_block index_zero_mat(3) ja length_map length_upt mat_of_rows_carrier(2))
    also have "... = ?xs_abs ! i $v ja" 
      by (rule mat_of_rows_index, insert i True ja , auto simp add: append_rows_def)
    also have "... = ?lhs_abs $$ (i,ja)"
      by (rule map_first_rows_index, insert assms lhs_carrier_abs True i ja_n, auto)
    finally show ?thesis ..
  next
    case False
    have "(?A'_abs @r ?D) $$ (i, ja) = ?D $$ (i-m,ja)"
      by (smt False Nat.add_0_right map_A_carrier_abs append_rows_def carrier_matD i 
          index_mat_four_block index_zero_mat(3) ja_n)
    also have "... = ?lhs_abs $$ (i,ja)"
      by (metis (no_types, lifting) False Nat.add_0_right map_A_carrier_abs append_rows_def A_def A' a 
          carrier_matD i index_mat_addrow(1) index_mat_four_block(1,2) index_zero_mat(3) ja_n 
          lhs_carrier_abs reduce_element_mod_D_abs_def reduce_element_mod_D_preserves_dimensions)
    finally show ?thesis ..
  qed
qed


lemma reduce_append_rows_eq:
  assumes A': "A'  carrier_mat m n"
    and A_def: "A = A' @r (D m (1m n))" and a: "a<m" and xm: "x<m" and "0<n"
  and Aaj: "A $$ (a,0)  0" 
  shows "reduce a x D A 
  = mat_of_rows n [Matrix.row ((reduce a x D A)) i. i  [0..<m]] @r D m 1m n" (is ?thesis1)
  and "reduce_abs a x D A 
  = mat_of_rows n [Matrix.row ((reduce_abs a x D A)) i. i  [0..<m]] @r D m 1m n" (is ?thesis2)
  unfolding atomize_conj
proof (rule conjI; rule matrix_append_rows_eq_if_preserves)
  let ?reduce_ax = "reduce a x D A"
  let ?reduce_abs = "reduce_abs a x D A"
 obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
   by (metis prod_cases5)
  have A: "A: carrier_mat (m+n) n" by (simp add: A_def A')
  show D1: "D m 1m n  carrier_mat n n" and "D m 1m n  carrier_mat n n" by simp+
  show "?reduce_ax  carrier_mat (m + n) n"  "?reduce_abs  carrier_mat (m + n) n"
    by (metis Nat.add_0_right append_rows_def A' A_def carrier_matD carrier_mat_triv index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2) index_zero_mat(3) reduce_preserves_dimensions)+
  show "i{m..<m + n}. ja<n. ?reduce_ax $$ (i, ja) = (D m 1m n) $$ (i - m, ja)" 
    and "i{m..<m + n}. ja<n. ?reduce_abs $$ (i, ja) = (D m 1m n) $$ (i - m, ja)"
    unfolding atomize_conj
  proof (rule conjI; rule+)
    fix i ja assume i: "i  {m..<m + n}" and ja: "ja < n"
    have ja_dc: "ja < dim_col A" and i_dr: "i < dim_row A" using i ja A by auto
    have i_not_a: "i  a" using i a by auto
    have i_not_x: "i  x" using i xm by auto
    have "?reduce_ax $$ (i,ja) = A $$ (i,ja)" 
      unfolding reduce_alt_def_not0[OF Aaj pquvd] using ja_dc i_dr i_not_a i_not_x by auto 
    also have "... = (if i < dim_row A' then A' $$(i,ja) else (D m (1m n))$$(i-m,ja))"
      by (unfold A_def, rule append_rows_nth[OF A' D1 _ ja], insert A i_dr, simp)
    also have "... = (D m 1m n) $$ (i - m, ja)" using i A' by auto
    finally show "?reduce_ax $$ (i,ja) = (D m 1m n) $$ (i - m, ja)" .   
    have "?reduce_abs $$ (i,ja) = A $$ (i,ja)" 
      unfolding reduce_alt_def_not0[OF Aaj pquvd] using ja_dc i_dr i_not_a i_not_x by auto 
    also have "... = (if i < dim_row A' then A' $$(i,ja) else (D m (1m n))$$(i-m,ja))"
      by (unfold A_def, rule append_rows_nth[OF A' D1 _ ja], insert A i_dr, simp)
    also have "... = (D m 1m n) $$ (i - m, ja)" using i A' by auto
    finally show "?reduce_abs $$ (i,ja) = (D m 1m n) $$ (i - m, ja)" .   
  qed
qed

fun reduce_row_mod_D
  where "reduce_row_mod_D A a [] D m = A" |
        "reduce_row_mod_D A a (x # xs) D m = reduce_row_mod_D (reduce_element_mod_D A a x D m) a xs D m"

fun reduce_row_mod_D_abs
  where "reduce_row_mod_D_abs A a [] D m = A" |
        "reduce_row_mod_D_abs A a (x # xs) D m = reduce_row_mod_D_abs (reduce_element_mod_D_abs A a x D m) a xs D m"


lemma reduce_row_mod_D_preserves_dimensions:
  shows [simp]: "dim_row (reduce_row_mod_D A a xs D m) = dim_row A" 
    and [simp]: "dim_col (reduce_row_mod_D A a xs D m) = dim_col A"
  by (induct A a xs D m rule: reduce_row_mod_D.induct, auto)
  
lemma reduce_row_mod_D_preserves_dimensions_abs:
  shows [simp]: "dim_row (reduce_row_mod_D_abs A a xs D m) = dim_row A" 
    and [simp]: "dim_col (reduce_row_mod_D_abs A a xs D m) = dim_col A"
  by (induct A a xs D m rule: reduce_row_mod_D_abs.induct, auto)

lemma reduce_row_mod_D_invertible_mat:
  assumes A_def: "A = A' @r (D m (1m n))"
  and A': "A'  carrier_mat m n" and a: "a<m" and j: "jset xs. j<n" and mn: "mn"
  shows "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  
    reduce_row_mod_D A a xs D m = P * A"
  using assms
proof (induct A a xs D m arbitrary: A' rule: reduce_row_mod_D.induct)
  case (1 A a D m)
  show ?case by (rule exI[of _ "1m (m+n)"], insert "1.prems", auto simp add: append_rows_def)
next
  case (2 A a x xs D m)
  let ?reduce_xs = "(reduce_element_mod_D A a x D m)"
  have 1: "reduce_row_mod_D A a (x # xs) D m 
    = reduce_row_mod_D ?reduce_xs a xs D m" by simp
  have "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  
    reduce_element_mod_D A a x D m = P * A" 
    by (rule reduce_element_mod_D_invertible_mat, insert "2.prems", auto)
  from this obtain P where P: "P  carrier_mat (m+n) (m+n)" and inv_P: "invertible_mat P"
    and R_P: "reduce_element_mod_D A a x D m = P * A" by auto
  have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P  reduce_row_mod_D ?reduce_xs a xs D m = P * ?reduce_xs"
  proof (rule "2.hyps")
    let ?A' = "mat_of_rows n [Matrix.row (reduce_element_mod_D A a x D m) i. i  [0..<m]]"
    show "reduce_element_mod_D A a x D m = ?A' @r (D m (1m n))"
      by (rule reduce_element_mod_D_append, insert "2.prems", auto)
  qed (insert "2.prems", auto)   
  from this obtain P2 where P2: "P2  carrier_mat (m + n) (m + n)" and inv_P2: "invertible_mat P2"
    and R_P2: "reduce_row_mod_D ?reduce_xs a xs D m = P2 * ?reduce_xs"
    by auto
  have "invertible_mat (P2 * P)" using P P2 inv_P inv_P2 invertible_mult_JNF by blast
  moreover have "(P2 * P)  carrier_mat (m+n) (m+n)" using P2 P by auto
  moreover have "reduce_row_mod_D A a (x # xs) D m = (P2 * P) * A" 
    by (smt P P2 R_P R_P2 1 assoc_mult_mat carrier_matD carrier_mat_triv
        index_mult_mat reduce_row_mod_D_preserves_dimensions)
  ultimately show ?case by blast
qed


lemma reduce_row_mod_D_abs_invertible_mat:
  assumes A_def: "A = A' @r (D m (1m n))"
  and A': "A'  carrier_mat m n" and a: "a<m" and j: "jset xs. j<n" and mn: "mn"
  shows "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  
    reduce_row_mod_D_abs A a xs D m = P * A"
  using assms
proof (induct A a xs D m arbitrary: A' rule: reduce_row_mod_D_abs.induct)
  case (1 A a D m)
  show ?case by (rule exI[of _ "1m (m+n)"], insert "1.prems", auto simp add: append_rows_def)
next
  case (2 A a x xs D m)
  let ?reduce_xs = "(reduce_element_mod_D_abs A a x D m)"
  have 1: "reduce_row_mod_D_abs A a (x # xs) D m 
    = reduce_row_mod_D_abs ?reduce_xs a xs D m" by simp
  have "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  
    reduce_element_mod_D_abs A a x D m = P * A" 
    by (rule reduce_element_mod_D_invertible_mat, insert "2.prems", auto)
  from this obtain P where P: "P  carrier_mat (m+n) (m+n)" and inv_P: "invertible_mat P"
    and R_P: "reduce_element_mod_D_abs A a x D m = P * A" by auto
  have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P  reduce_row_mod_D_abs ?reduce_xs a xs D m = P * ?reduce_xs"
  proof (rule "2.hyps")
    let ?A' = "mat_of_rows n [Matrix.row (reduce_element_mod_D_abs A a x D m) i. i  [0..<m]]"
    show "reduce_element_mod_D_abs A a x D m = ?A' @r (D m (1m n))"
      by (rule reduce_element_mod_D_append, insert "2.prems", auto)
  qed (insert "2.prems", auto)   
  from this obtain P2 where P2: "P2  carrier_mat (m + n) (m + n)" and inv_P2: "invertible_mat P2"
    and R_P2: "reduce_row_mod_D_abs ?reduce_xs a xs D m = P2 * ?reduce_xs"
    by auto
  have "invertible_mat (P2 * P)" using P P2 inv_P inv_P2 invertible_mult_JNF by blast
  moreover have "(P2 * P)  carrier_mat (m+n) (m+n)" using P2 P by auto
  moreover have "reduce_row_mod_D_abs A a (x # xs) D m = (P2 * P) * A" 
    by (smt P P2 R_P R_P2 1 assoc_mult_mat carrier_matD carrier_mat_triv
        index_mult_mat reduce_row_mod_D_preserves_dimensions_abs)
  ultimately show ?case by blast
qed
end

context proper_mod_operation
begin
lemma dvd_gdiv_mult_left[simp]: assumes "b > 0" "b dvd a" shows "b * (a gdiv b) = a"
  using dvd_gdiv_mult_right[OF assms] by (auto simp: ac_simps)


lemma reduce_element_mod_D:
  assumes A_def: "A = A' @r  (D m (1m n))"
  and A': "A'  carrier_mat m n" and a: "am" and j: "j<n" and mn: "mn"
  and D: "D > 0" 
  shows "reduce_element_mod_D A a j D m = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a  k = j then if j = 0 then if D dvd A$$(i,k) 
          then D else A$$(i,k) else A$$(i,k) gmod D else A$$(i,k))" (is "_ = ?A")
    and "reduce_element_mod_D_abs A a j D m = Matrix.mat (dim_row A) (dim_col A)
      (λ(i,k). if i = a  k = j then if j = 0  D dvd A$$(i,k) then D else A$$(i,k) gmod D else A$$(i,k))" (is "_ = ?A_abs")
unfolding atomize_conj
proof (rule conjI; rule eq_matI)
  have A: "A  carrier_mat (m+n) n" using A_def A'  by simp
  have dr: "dim_row ?A = dim_row ?A_abs" and dc: "dim_col ?A = dim_col ?A_abs" by auto
  have 1: "reduce_element_mod_D A a j D m $$ (i, ja) = ?A $$ (i, ja)" (is ?thesis1)
    and 2: "reduce_element_mod_D_abs A a j D m $$ (i, ja) = ?A_abs $$ (i, ja)" (is ?thesis2)
    if i: "i < dim_row ?A" and ja: "ja < dim_col ?A" for i ja
    unfolding atomize_conj
  proof (rule conjI; cases "i=a")
    case False
    have "reduce_element_mod_D A a j D m = (if j = 0 then if D dvd A$$(a,j) then addrow (-((A$$(a,j) gdiv D)) + 1) a (j + m) A 
    else A
    else addrow (-((A$$(a,j) gdiv D))) a (j + m) A)"
      unfolding reduce_element_mod_D_def by simp
    also have "... $$ (i,ja) = A $$ (i, ja)" unfolding mat_addrow_def using False ja i by auto     
    also have "... = ?A $$ (i,ja)" using False using i ja by auto
    finally show ?thesis1 .
    have "reduce_element_mod_D_abs A a j D m $$ (i,ja) = A $$ (i, ja)"
      unfolding reduce_element_mod_D_abs_def mat_addrow_def using False ja i by auto     
    also have "... = ?A_abs $$ (i,ja)" using False using i ja by auto
    finally show ?thesis2 .
  next
    case True note ia = True
    have "reduce_element_mod_D A a j D m 
      = (if j = 0 then if D dvd A$$(a,j) then addrow (-((A$$(a,j) gdiv D)) + 1) a (j + m) A else A
        else addrow (-((A$$(a,j) gdiv D))) a (j + m) A)" 
      unfolding reduce_element_mod_D_def by simp
    also have "... $$ (i,ja) = ?A $$ (i,ja)"
    proof (cases "ja = j")
      case True note ja_j = True
      have "A $$ (j + m, ja) = (D m (1m n)) $$ (j,ja)"
        by (rule append_rows_nth2[OF A' _ A_def ], insert j ja A mn, auto)       
      also have "... = D * (1m n) $$ (j,ja)" by (rule index_smult_mat, insert ja j A mn, auto)
      also have "... = D" by (simp add: True j mn)
      finally have A_ja_jaD: "A $$ (j + m, ja) = D" .
      show ?thesis
      proof (cases "j=0  D dvd A$$(a,j)")
        case True         
        have 1: "reduce_element_mod_D A a j D m = addrow (-((A$$(a,j) gdiv D)) + 1) a (j + m) A "
          using True ia ja_j unfolding reduce_element_mod_D_def by auto
        also have "... $$(i,ja) = (- (A $$ (a, j) gdiv D) + 1) * A $$ (j + m, ja) + A $$ (i, ja)"
          unfolding mat_addrow_def using True ja_j ia
          using A i j by auto
        also have "... = D"
        proof -
          have "A $$ (i, ja) + D * - (A $$ (i, ja) gdiv D) = 0"
            using True ia ja_j D by force
          then show ?thesis
            by (metis A_ja_jaD ab_semigroup_add_class.add_ac(1) add.commute add_right_imp_eq ia int_distrib(2)
                ja_j more_arith_simps(3) mult.commute mult_cancel_right1)
        qed   
        also have "... = ?A $$ (i,ja)" using True ia A i j ja_j by auto
        finally show ?thesis
          using True 1 by auto
      next
        case False
        show ?thesis
        proof (cases "ja=0")
          case True
          then show ?thesis
            using False i ja ja_j by force
        next
          case False
        have "?A $$ (i,ja) = A $$ (i, ja) gmod D" using True ia A i j False by auto
        also have "... = A $$ (i, ja) - ((A $$ (i, ja) gdiv D) * D)"
          by (subst gmod_gdiv[OF D], auto)
        also have "... =  - (A $$ (a, j) gdiv D) * A $$ (j + m, ja) + A $$ (i, ja)"
          unfolding A_ja_jaD by (simp add: True ia)
        finally show ?thesis 
          using A False True i ia j by auto
      qed
    qed
  next
      case False
      have "A $$ (j + m, ja) = (D m (1m n)) $$ (j,ja)"
        by (rule append_rows_nth2[OF A' _ A_def ], insert j mn ja A, auto)       
      also have "... = D * (1m n) $$ (j,ja)" by (rule index_smult_mat, insert ja j A mn, auto)
      also have "... = 0" using False using A a mn ja j by force        
      finally have A_am_ja0: "A $$ (j + m, ja) = 0" .
      then show ?thesis using False i ja by fastforce
    qed
    finally show ?thesis1 .
    have "reduce_element_mod_D_abs A a j D m 
      = (if j = 0  D dvd A$$(a,j) then addrow (-((A$$(a,j) gdiv D)) + 1) a (j + m) A
        else addrow (-((A$$(a,j) gdiv D))) a (j + m) A)" 
      unfolding reduce_element_mod_D_abs_def by simp
    also have "... $$ (i,ja) = ?A_abs $$ (i,ja)"
    proof (cases "ja = j")
      case True note ja_j = True
      have "A $$ (j + m, ja) = (D m (1m n)) $$ (j,ja)"
        by (rule append_rows_nth2[OF A' _ A_def ], insert j ja A mn, auto)       
      also have "... = D * (1m n) $$ (j,ja)" by (rule index_smult_mat, insert ja j A mn, auto)
      also have "... = D" by (simp add: True j mn)
      finally have A_ja_jaD: "A $$ (j + m, ja) = D" .
      show ?thesis
      proof (cases "j=0  D dvd A$$(a,j)")
        case True         
        have 1: "reduce_element_mod_D_abs A a j D m = addrow (-((A$$(a,j) gdiv D)) + 1) a (j + m) A "
          using True ia ja_j unfolding reduce_element_mod_D_abs_def by auto
        also have "... $$(i,ja) = (- (A $$ (a, j) gdiv D) + 1) * A $$ (j + m, ja) + A $$ (i, ja)"
          unfolding mat_addrow_def using True ja_j ia
          using A i j by auto
        also have "... = D"
        proof -
          have "A $$ (i, ja) + D * - (A $$ (i, ja) gdiv D) = 0"
            using True ia ja_j D by force
          then show ?thesis
            by (metis A_ja_jaD ab_semigroup_add_class.add_ac(1) add.commute add_right_imp_eq ia int_distrib(2)
                ja_j more_arith_simps(3) mult.commute mult_cancel_right1)
        qed   
        also have "... = ?A_abs $$ (i,ja)" using True ia A i j ja_j by auto
        finally show ?thesis
          using True 1 by auto
      next
        case False
        have i: "i<dim_row ?A_abs" and ja: "ja<dim_col ?A_abs" using i ja by auto
        have "?A_abs $$ (i,ja) = A $$ (i, ja) gmod D" using True ia A i j False by auto
        also have "... = A $$ (i, ja) - ((A $$ (i, ja) gdiv D) * D)"
          by (subst gmod_gdiv[OF D], auto)
        also have "... =  - (A $$ (a, j) gdiv D) * A $$ (j + m, ja) + A $$ (i, ja)"
          unfolding A_ja_jaD by (simp add: True ia)
        finally show ?thesis 
          using A False True i ia j by auto
      qed    
  next
      case False
      have "A $$ (j + m, ja) = (D m (1m n)) $$ (j,ja)"
        by (rule append_rows_nth2[OF A' _ A_def ], insert j mn ja A, auto)       
      also have "... = D * (1m n) $$ (j,ja)" by (rule index_smult_mat, insert ja j A mn, auto)
      also have "... = 0" using False using A a mn ja j by force        
      finally have A_am_ja0: "A $$ (j + m, ja) = 0" .
      then show ?thesis using False i ja by fastforce
    qed
    finally show ?thesis2 .  
  qed
  from this
  show "i ja. i<dim_row ?A  ja < dim_col ?A  reduce_element_mod_D A a j D m $$ (i, ja) = ?A $$ (i, ja)" 
    and "i ja. i<dim_row ?A_abs  ja < dim_col ?A_abs  reduce_element_mod_D_abs A a j D m $$ (i, ja) = ?A_abs $$ (i, ja)" 
    using dr dc by auto
next
  show "dim_row (reduce_element_mod_D A a j D m) = dim_row ?A" 
    and "dim_col (reduce_element_mod_D A a j D m) = dim_col ?A"
    "dim_row (reduce_element_mod_D_abs A a j D m) = dim_row ?A_abs" 
    and "dim_col (reduce_element_mod_D_abs A a j D m) = dim_col ?A_abs"
    by auto
qed


lemma reduce_row_mod_D:
  assumes A_def: "A = A' @r (D m (1m n))"
    and A': "A'  carrier_mat m n" and a: "a<m" and j: "jset xs. j<n"
    and d: "distinct xs" and "mn"
    and "D > 0" 
  shows "reduce_row_mod_D A a xs D m = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a  k  set xs then if k = 0 then if D dvd A$$(i,k) 
           then D else A$$(i,k) else A$$(i,k) gmod D else A$$(i,k))"
  using assms
proof (induct A a xs D m arbitrary: A' rule: reduce_row_mod_D.induct)
  case (1 A a D m)
  then show ?case by force
next
  case (2 A a x xs D m)
  let ?reduce_xs = "(reduce_element_mod_D A a x D m)"
  have 1: "reduce_row_mod_D A a (x # xs) D m 
    = reduce_row_mod_D ?reduce_xs a xs D m" by simp
  have 2: "reduce_element_mod_D A a j D m = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a  k = j then if j = 0 then if D dvd A$$(i,k)
          then D else A$$(i,k) else A$$(i,k) gmod D else A$$(i,k))" if "j<n" for j
    by (rule reduce_element_mod_D, insert "2.prems" that, auto)
  have "reduce_row_mod_D ?reduce_xs a xs D m =
    Matrix.mat (dim_row ?reduce_xs) (dim_col ?reduce_xs) (λ(i,k). if i = a  k  set xs then 
    if k=0 then if D dvd ?reduce_xs $$ (i, k) then D else ?reduce_xs $$ (i, k)
    else ?reduce_xs $$ (i, k) gmod D else ?reduce_xs $$ (i, k))"
  proof (rule "2.hyps")
    let ?A' = "mat_of_rows n [Matrix.row (reduce_element_mod_D A a x D m) i. i  [0..<m]]"
    show "reduce_element_mod_D A a x D m = ?A' @r (D m (1m n))"
      by (rule reduce_element_mod_D_append, insert "2.prems", auto)
  qed (insert "2.prems", auto)
  also have "... = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a  k  set (x # xs) then if k = 0 then if D dvd A$$(i,k)
          then D else A$$(i,k) else A$$(i,k) gmod D else A$$(i,k))" (is "?lhs = ?rhs")
  proof (rule eq_matI) 
    show "dim_row ?lhs = dim_row ?rhs" and "dim_col ?lhs = dim_col ?rhs" by auto
    fix i j assume i: "i<dim_row ?rhs" and j: "j < dim_col ?rhs"
    have jn: "j<n" using j "2.prems" by (simp add: append_rows_def)
    have xn: "x < n" by (simp add: "2.prems"(4))
    show "?lhs $$ (i,j) = ?rhs $$ (i,j)"
    proof (cases "i=a  j  set xs")
      case True note ia_jxs = True
      have j_not_x: "jx"
        using "2.prems"(5) True by auto
      show ?thesis
      proof (cases "j=0  D dvd ?reduce_xs $$(i,j)")
        case True
        have "?lhs $$ (i,j) = D"
          using True i j ia_jxs by auto
        also have "... = ?rhs $$ (i,j)" using i j j_not_x 
          by (smt "2" calculation dim_col_mat(1) dim_row_mat(1) index_mat(1) insert_iff list.set(2) prod.simps(2) xn)
        finally show ?thesis .
      next
        case False note nc1 = False
        show ?thesis
        proof (cases "j=0")
          case True
          then show ?thesis
            by (smt (z3) "2" False case_prod_conv dim_col_mat(1) dim_row_mat(1) i index_mat(1) j j_not_x xn)
        next
          case False          
      have "?lhs $$ (i,j) = ?reduce_xs $$ (i, j) gmod D"
        using True False i j by auto
      also have "... = A $$ (i,j) gmod D" using 2[OF xn] j_not_x i j by auto
      also have "... = ?rhs $$ (i,j)" using i j j_not_x D > 0        
        using False True dim_col_mat(1) dim_row_mat(1) index_mat(1) list.set_intros(2) old.prod.case
        by auto
      finally show ?thesis .
    qed
  qed
  next
      case False
      show ?thesis using 2 i j xn 
        by (smt False dim_col_mat(1) dim_row_mat(1) index_mat(1) insert_iff list.set(2) prod.simps(2))
    qed   
  qed  
  finally show ?case using 1 by simp
qed




lemma reduce_row_mod_D_abs:
  assumes A_def: "A = A' @r (D m (1m n))"
    and A': "A'  carrier_mat m n" and a: "a<m" and j: "jset xs. j<n"
    and d: "distinct xs" and "mn"
    and "D > 0" 
  shows "reduce_row_mod_D_abs A a xs D m = Matrix.mat (dim_row A) (dim_col A)
             (λ(i,k). if i = a  k  set xs then if k = 0  D dvd A$$(i,k)
              then D else A$$(i,k) gmod D else A$$(i,k))"
  using assms
proof (induct A a xs D m arbitrary: A' rule: reduce_row_mod_D_abs.induct)
  case (1 A a D m)
  then show ?case by force
next
  case (2 A a x xs D m)
  let ?reduce_xs = "(reduce_element_mod_D_abs A a x D m)"
  have 1: "reduce_row_mod_D_abs A a (x # xs) D m 
    = reduce_row_mod_D_abs ?reduce_xs a xs D m" by simp
  have 2: "reduce_element_mod_D_abs A a j D m = Matrix.mat (dim_row A) (dim_col A)
  (λ(i,k). if i = a  k = j then if j = 0  D dvd A$$(i,k) then D 
    else A$$(i,k) gmod D else A$$(i,k))" if "j<n" for j
    by (rule reduce_element_mod_D, insert "2.prems" that, auto)
  have "reduce_row_mod_D_abs ?reduce_xs a xs D m =
    Matrix.mat (dim_row ?reduce_xs) (dim_col ?reduce_xs) (λ(i,k). if i = a  k  set xs then 
    if k=0  D dvd ?reduce_xs $$ (i, k) then D
    else ?reduce_xs $$ (i, k) gmod D else ?reduce_xs $$ (i, k))"
  proof (rule "2.hyps")
    let ?A' = "mat_of_rows n [Matrix.row (reduce_element_mod_D_abs A a x D m) i. i  [0..<m]]"
    show "reduce_element_mod_D_abs A a x D m = ?A' @r (D m (1m n))"
      by (rule reduce_element_mod_D_append, insert "2.prems", auto)
  qed (insert "2.prems", auto)
  also have "... = Matrix.mat (dim_row A) (dim_col A)
            (λ(i,k). if i = a  k  set (x # xs) then if k = 0  D dvd A$$(i,k)
            then D else A$$(i,k) gmod D else A$$(i,k))" (is "?lhs = ?rhs")
  proof (rule eq_matI) 
    show "dim_row ?lhs = dim_row ?rhs" and "dim_col ?lhs = dim_col ?rhs" by auto
    fix i j assume i: "i<dim_row ?rhs" and j: "j < dim_col ?rhs"
    have jn: "j<n" using j "2.prems" by (simp add: append_rows_def)
    have xn: "x < n" by (simp add: "2.prems"(4))
    show "?lhs $$ (i,j) = ?rhs $$ (i,j)"
    proof (cases "i=a  j  set xs")
      case True note ia_jxs = True
      have j_not_x: "jx"
        using "2.prems"(5) True by auto
      show ?thesis
      proof (cases "j=0  D dvd ?reduce_xs $$(i,j)")
        case True
        have "?lhs $$ (i,j) = D"
          using True i j ia_jxs by auto
        also have "... = ?rhs $$ (i,j)" using i j j_not_x 
          by (smt "2" calculation dim_col_mat(1) dim_row_mat(1) index_mat(1) insert_iff list.set(2) prod.simps(2) xn)
        finally show ?thesis .
      next
        case False 
      have "?lhs $$ (i,j) = ?reduce_xs $$ (i, j) gmod D"
        using True False i j by auto
      also have "... = A $$ (i,j) gmod D" using 2[OF xn] j_not_x i j by auto
      also have "... = ?rhs $$ (i,j)" using i j j_not_x D > 0  
        using "2" False True dim_col_mat(1) dim_row_mat(1) index_mat(1) list.set_intros(2) 
          old.prod.case xn by auto     
      finally show ?thesis .
    qed  
  next
      case False
      show ?thesis using 2 i j xn 
        by (smt False dim_col_mat(1) dim_row_mat(1) index_mat(1) insert_iff list.set(2) prod.simps(2))
    qed   
  qed  
  finally show ?case using 1 by simp
qed
end


text ‹Now, we prove some transfer rules to connect B\'ezout matrices in HOL Analysis and JNF›
(*Connecting Bezout Matrix in HOL Analysis (thm bezout_matrix_def) and JNF (thm bezout_matrix_JNF_def)*)
lemma HMA_bezout_matrix[transfer_rule]:
  shows "((Mod_Type_Connect.HMA_M :: _  'a :: {bezout_ring} ^ 'n :: mod_type ^ 'm :: mod_type  _) 
  ===> (Mod_Type_Connect.HMA_I :: _  'm  _) ===> (Mod_Type_Connect.HMA_I :: _  'm  _) 
  ===> (Mod_Type_Connect.HMA_I :: _  'n  _) ===> (=) ===> (Mod_Type_Connect.HMA_M)) 
  (bezout_matrix_JNF) (bezout_matrix)" 
proof (intro rel_funI, goal_cases)
  case (1 A A' a a' b b' j j' bezout bezout')
  note HMA_AA'[transfer_rule] = "1"(1)
  note HMI_aa'[transfer_rule] = "1"(2)
  note HMI_bb'[transfer_rule] = "1"(3)
  note HMI_jj'[transfer_rule] = "1"(4)
  note eq_bezout'[transfer_rule] = "1"(5)
  show ?case unfolding Mod_Type_Connect.HMA_M_def Mod_Type_Connect.from_hmam_def 
  proof (rule eq_matI) 
    let ?A = "Matrix.mat CARD('m) CARD('m) (λ(i, j). bezout_matrix A' a' b' j' bezout' 
        $h mod_type_class.from_nat i $h mod_type_class.from_nat j)"
    show "dim_row (bezout_matrix_JNF A a b j bezout) = dim_row ?A"
      and "dim_col (bezout_matrix_JNF A a b j bezout) = dim_col ?A"
      using Mod_Type_Connect.dim_row_transfer_rule[OF HMA_AA']
      unfolding bezout_matrix_JNF_def by auto  
    fix i ja assume i: "i < dim_row ?A" and ja: "ja < dim_col ?A"
    let ?i = "mod_type_class.from_nat i :: 'm"
    let ?ja = "mod_type_class.from_nat ja :: 'm"    
    have i_A: "i < dim_row A"
      using HMA_AA' Mod_Type_Connect.dim_row_transfer_rule i by fastforce
    have ja_A: "ja < dim_row A"
      using Mod_Type_Connect.dim_row_transfer_rule[OF HMA_AA'] ja by fastforce
    have HMA_I_ii'[transfer_rule]: "Mod_Type_Connect.HMA_I i ?i"
      unfolding Mod_Type_Connect.HMA_I_def using from_nat_not_eq i by auto
    have HMA_I_ja'[transfer_rule]: "Mod_Type_Connect.HMA_I ja ?ja"
      unfolding Mod_Type_Connect.HMA_I_def using from_nat_not_eq ja by auto
    have Aaj: "A' $h a' $h j' = A $$ (a,j)" unfolding index_hma_def[symmetric] by (transfer, simp)
    have Abj: "A' $h b' $h j' = A $$ (b, j)" unfolding index_hma_def[symmetric] by (transfer, simp) 
    have "?A $$ (i, ja) = bezout_matrix A' a' b' j' bezout' $h ?i $h ?ja" using i ja by auto
    also have "... = (let (p, q, u, v, d) = bezout' (A' $h a' $h j') (A' $h b' $h j')
            in if ?i = a'  ?ja = a' then p else if ?i = a'  ?ja = b' then q else if ?i = b'  ?ja = a' 
            then u else if ?i = b'  ?ja = b' then v else if ?i = ?ja then 1 else 0)" 
      unfolding bezout_matrix_def by auto
    also have "... =  (let 
        (p, q, u, v, d) = bezout (A $$ (a, j)) (A $$ (b, j)) 
       in
         if i = a  ja = a then p else
         if i = a  ja = b then q else
         if i = b  ja = a then u else
         if i = b  ja = b then v else
         if i = ja then 1 else 0)" unfolding eq_bezout' Aaj Abj by (transfer, simp)
    also have "... = bezout_matrix_JNF A a b j bezout $$ (i,ja)"
      unfolding bezout_matrix_JNF_def using i_A ja_A by auto
    finally show "bezout_matrix_JNF A a b j bezout $$ (i, ja) = ?A $$ (i, ja)" ..
  qed
qed

(*thm invertible_bezout_matrix must be transferred from HOL Analysis to JNF*)

context
begin

private lemma invertible_bezout_matrix_JNF_mod_type:
  fixes A::"'a::{bezout_ring_div} mat"
  assumes "A  carrier_mat CARD('m::mod_type) CARD('n::mod_type)"
  assumes ib: "is_bezout_ext bezout"
  and a_less_b: "a < b" and b: "b<CARD('m)" and j: "j<CARD('n)"
  and aj: "A $$ (a, j)  0"
shows "invertible_mat (bezout_matrix_JNF A a b j bezout)" 
proof -
  define A' where "A' = (Mod_Type_Connect.to_hmam A :: 'a ^'n :: mod_type ^'m :: mod_type)"
  define a' where "a' = (Mod_Type.from_nat a :: 'm)"
  define b' where "b' = (Mod_Type.from_nat b :: 'm)"
  define j' where "j' = (Mod_Type.from_nat j :: 'n)"
  have AA'[transfer_rule]: "Mod_Type_Connect.HMA_M A A'"
    unfolding Mod_Type_Connect.HMA_M_def using assms A'_def by auto
  have aa'[transfer_rule]: "Mod_Type_Connect.HMA_I a a'"
    unfolding Mod_Type_Connect.HMA_I_def a'_def using assms
    using from_nat_not_eq order.strict_trans by blast
  have bb'[transfer_rule]: "Mod_Type_Connect.HMA_I b b'"
    unfolding Mod_Type_Connect.HMA_I_def b'_def using assms
    using from_nat_not_eq order.strict_trans by blast
  have jj'[transfer_rule]: "Mod_Type_Connect.HMA_I j j'"
    unfolding Mod_Type_Connect.HMA_I_def j'_def using assms
    using from_nat_not_eq order.strict_trans by blast
  have [transfer_rule]: "bezout = bezout" ..
  have [transfer_rule]: "Mod_Type_Connect.HMA_M (bezout_matrix_JNF A a b j bezout) 
      (bezout_matrix A' a' b' j' bezout)"
    by transfer_prover
  have "invertible (bezout_matrix A' a' b' j' bezout)"
  proof (rule invertible_bezout_matrix[OF ib])
    show "a' < b'" using a_less_b by (simp add: a'_def b b'_def from_nat_mono)
    show "A' $h a' $h j'  0" unfolding index_hma_def[symmetric] using aj by (transfer, simp)
  qed
  thus ?thesis by (transfer, simp)
qed 

private lemma invertible_bezout_matrix_JNF_nontriv_mod_ring:
  fixes A::"'a::{bezout_ring_div} mat"
  assumes "A  carrier_mat CARD('m::nontriv mod_ring) CARD('n::nontriv mod_ring)"
  assumes ib: "is_bezout_ext bezout"
  and a_less_b: "a < b" and b: "b<CARD('m)" and j: "j<CARD('n)"
  and aj: "A $$ (a, j)  0"
shows "invertible_mat (bezout_matrix_JNF A a b j bezout)" 
  using assms invertible_bezout_matrix_JNF_mod_type by (smt CARD_mod_ring) 


(*We internalize both sort constraints in one step*)
lemmas invertible_bezout_matrix_JNF_internalized = 
  invertible_bezout_matrix_JNF_nontriv_mod_ring[unfolded CARD_mod_ring, 
      internalize_sort "'m::nontriv", internalize_sort "'c::nontriv"]

context
  fixes m::nat and n::nat
  assumes local_typedef1: "(Rep :: ('b  int)) Abs. type_definition Rep Abs {0..<m :: int}"
  assumes local_typedef2: "(Rep :: ('c  int)) Abs. type_definition Rep Abs {0..<n :: int}"
  and m: "m>1"
  and n: "n>1"
begin

lemma type_to_set1:
  shows "class.nontriv TYPE('b)" (is ?a) and "m=CARD('b)" (is ?b)
proof -
  from local_typedef1 obtain Rep::"('b  int)" and Abs 
    where t: "type_definition Rep Abs {0..<m :: int}" by auto
  have "card (UNIV :: 'b set) = card {0..<m}" using t type_definition.card by fastforce
  also have "... = m" by auto
  finally show ?b ..
  then show ?a unfolding class.nontriv_def using m by auto
qed

lemma type_to_set2:
  shows "class.nontriv TYPE('c)" (is ?a) and "n=CARD('c)" (is ?b)
proof -
  from local_typedef2 obtain Rep::"('c  int)" and Abs 
    where t: "type_definition Rep Abs {0..<n :: int}" by blast
  have "card (UNIV :: 'c set) = card {0..<n}" using t type_definition.card by force
  also have "... = n" by auto
  finally show ?b ..
  then show ?a unfolding class.nontriv_def using n by auto
qed


lemma invertible_bezout_matrix_JNF_nontriv_mod_ring_aux:
  fixes A::"'a::{bezout_ring_div} mat"
  assumes "A  carrier_mat m n"
  assumes ib: "is_bezout_ext bezout"
  and a_less_b: "a < b" and b: "b<m" and j: "j<n"
  and aj: "A $$ (a, j)  0"
shows "invertible_mat (bezout_matrix_JNF A a b j bezout)" 
  using invertible_bezout_matrix_JNF_internalized[OF type_to_set2(1) type_to_set(1), where ?'aa = 'b]
  using assms 
  using type_to_set1(2) type_to_set2(2) local_typedef1 m by blast
end


(*Canceling the first local type definitions*)
context
begin

(*Canceling the first*)
private lemma invertible_bezout_matrix_JNF_cancelled_first:
"Rep Abs. type_definition Rep Abs {0..<int n}  {0..<int m}  {} 
1 < m  1 < n 
(A::'a::bezout_ring_div mat)  carrier_mat m n  is_bezout_ext bezout 
 a < b  b < m  j < n  A $$ (a, j)  0  invertible_mat (bezout_matrix_JNF A a b j bezout)"
  using invertible_bezout_matrix_JNF_nontriv_mod_ring_aux[cancel_type_definition] by blast

(*Canceling the second*)
private lemma invertible_bezout_matrix_JNF_cancelled_both:
"{0..<int n}  {}  {0..<int m}  {}  1 < m  1 < n 
1 < m  1 < n 
(A::'a::bezout_ring_div mat)  carrier_mat m n  is_bezout_ext bezout 
 a < b  b < m  j < n  A $$ (a, j)  0  invertible_mat (bezout_matrix_JNF A a b j bezout)"
  using invertible_bezout_matrix_JNF_cancelled_first[cancel_type_definition] by blast

(*The final result in JNF*)
lemma invertible_bezout_matrix_JNF':
  fixes A::"'a::{bezout_ring_div} mat"
  assumes "A  carrier_mat m n"
  assumes ib: "is_bezout_ext bezout"
  and a_less_b: "a < b" and b: "b<m" and j: "j<n" 
  and "n>1" (* Required from the mod_type restrictions*)
  and aj: "A $$ (a, j)  0"
shows "invertible_mat (bezout_matrix_JNF A a b j bezout)" 
  using invertible_bezout_matrix_JNF_cancelled_both assms by auto

(*Trick: we want to get rid out the "n>1" assumption, which has appeared since CARD('m::mod_type)>1.
Given an mx1 matrix, we just append another column and the bezout_matrix is the same, so it will
also be invertible by the previous transfered theorem
*)
lemma invertible_bezout_matrix_JNF_n1:
  fixes A::"'a::{bezout_ring_div} mat"
  assumes A: "A  carrier_mat m n"
  assumes ib: "is_bezout_ext bezout"
  and a_less_b: "a < b" and b: "b<m" and j: "j<n" 
  and n1: "n=1" (* Required from the mod_type restrictions*)
  and aj: "A $$ (a, j)  0"
shows "invertible_mat (bezout_matrix_JNF A a b j bezout)" 
proof -
  let ?A = "A @c (0m m n)"
  have "(A @c 0m m n) $$ (a, j) =  (if j < dim_col A then A $$ (a, j) else (0m m n) $$ (a, j - n))"     
    by (rule append_cols_nth[OF A], insert assms, auto)
  also have "... = A $$ (a,j)" using assms by auto
  finally have Aaj: "(A @c 0m m n) $$ (a, j) =  A $$ (a,j)" .
  have "(A @c 0m m n) $$ (b, j) =  (if j < dim_col A then A $$ (b, j) else (0m m n) $$ (b, j - n))"     
    by (rule append_cols_nth[OF A], insert assms, auto)
  also have "... = A $$ (b,j)" using assms by auto
  finally have Abj: "(A @c 0m m n) $$ (b, j) = A $$ (b, j)" .
  have dr: "dim_row A = dim_row ?A"  by (simp add: append_cols_def)
  have dc: "dim_col ?A = 2"
    by (metis Suc_1 append_cols_def A n1 carrier_matD(2) index_mat_four_block(3) 
        index_zero_mat(3) plus_1_eq_Suc)
  have bz_eq: "bezout_matrix_JNF A a b j bezout = bezout_matrix_JNF ?A a b j bezout"
    unfolding bezout_matrix_JNF_def Aaj Abj dr by auto
  have "invertible_mat (bezout_matrix_JNF ?A a b j bezout)"
    by (rule invertible_bezout_matrix_JNF', insert assms Aaj Abj dr dc, auto)
  thus ?thesis using bz_eq by simp
qed

(*The final result in JNF without requiring n>1*)
corollary invertible_bezout_matrix_JNF:
  fixes A::"'a::{bezout_ring_div} mat"
  assumes "A  carrier_mat m n"
  assumes ib: "is_bezout_ext bezout"
  and a_less_b: "a < b" and b: "b<m" and j: "j<n" 
  and aj: "A $$ (a, j)  0"
shows "invertible_mat (bezout_matrix_JNF A a b j bezout)" 
  using invertible_bezout_matrix_JNF_n1 invertible_bezout_matrix_JNF' assms
  by (metis One_nat_def gr_implies_not0 less_Suc0 not_less_iff_gr_or_eq)

end
end

text ‹We continue with the soundness of the algorithm›

lemma bezout_matrix_JNF_mult_eq:
  assumes A': "A'  carrier_mat m n" and a: "am"  and b: "bm" and ab: "a  b" 
  and A_def: "A = A' @r B" and B: "B  carrier_mat n n"
  assumes pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,j)) (A$$(b,j))"
  shows "Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a then (p*A$$(a,k) + q*A$$(b,k))
                   else if i = b then u * A$$(a,k) + v * A$$(b,k)
                   else A$$(i,k)
            ) = (bezout_matrix_JNF A a b j euclid_ext2) * A" (is "?A = ?BM * A")
proof (rule eq_matI) 
  have A: "A  carrier_mat (m+n) n" using A_def A' B by simp
  hence A_carrier: "?A  carrier_mat (m+n) n" by auto  
  show dr: "dim_row ?A = dim_row (?BM * A)" and dc: "dim_col ?A = dim_col (?BM * A)"
    unfolding bezout_matrix_JNF_def by auto
  fix i ja assume i: "i < dim_row  (?BM * A)" and ja: "ja < dim_col (?BM * A)"
  let ?f = "λia. (bezout_matrix_JNF A a b j euclid_ext2) $$ (i,ia) * A $$ (ia,ja)"
  have dv: "dim_vec (col A ja) = m+n" using A by auto
  have i_dr: "i<dim_row A" using i A unfolding bezout_matrix_JNF_def by auto
  have a_dr: "a<dim_row A" using A a ja by auto
  have b_dr: "b<dim_row A" using A b ja by auto
  show "?A $$ (i,ja) = (?BM * A) $$ (i,ja)"
  proof -
    have "(?BM * A) $$ (i,ja) = Matrix.row ?BM i  col A ja"
      by (rule index_mult_mat, insert i ja, auto)
    also have "... = (ia = 0..<dim_vec (col A ja). 
          Matrix.row (bezout_matrix_JNF A a b j euclid_ext2) i $v ia * col A ja $v ia)"
      by (simp add: scalar_prod_def)
    also have "... = (ia = 0..<m+n. ?f ia)"
      by (rule sum.cong, insert A i dr dc, auto) (smt bezout_matrix_JNF_def carrier_matD(1) 
          dim_col_mat(1) index_col index_mult_mat(3) index_row(1) ja)
    also have "... = (ia  ({a,b}  ({0..<m+n} - {a,b})). ?f ia)"
      by (rule sum.cong, insert a a_dr b A ja, auto)
    also have "... = sum ?f {a,b} + sum ?f ({0..<m+n} - {a,b})" 
      by (rule sum.union_disjoint, auto)
    finally have BM_A_ija_eq: "(?BM * A) $$ (i,ja) = sum ?f {a,b} + sum ?f ({0..<m+n} - {a,b})" by auto
    show ?thesis
    proof (cases "i = a")
      case True
      have sum0: "sum ?f ({0..<m+n} - {a,b}) = 0"
      proof (rule sum.neutral, rule)
        fix x assume x: "x  {0..<m + n} - {a, b}"
        hence xm: "x < m+n" by auto
        have x_not_i: "x  i" using True x by blast
        have x_dr: "x < dim_row A" using x A by auto
        have "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, x) = 0"
          unfolding bezout_matrix_JNF_def 
          unfolding index_mat(1)[OF i_dr x_dr] using x_not_i x by auto
        thus "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, x) * A $$ (x, ja) = 0" by auto
      qed
      have fa: "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, a) = p" 
        unfolding bezout_matrix_JNF_def index_mat(1)[OF i_dr a_dr] using True pquvd 
        by (auto, metis split_conv)
      have fb: "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, b) = q"
        unfolding bezout_matrix_JNF_def index_mat(1)[OF i_dr b_dr] using True pquvd ab
        by (auto, metis split_conv)
      have "sum ?f {a,b} + sum ?f ({0..<m+n} - {a,b}) = ?f a + ?f b" using sum0 by (simp add: ab)
      also have "... = p * A $$ (a, ja) + q * A $$ (b, ja)" unfolding fa fb by simp
      also have "... = ?A $$ (i,ja)" using A True dr i ja by auto
      finally show ?thesis using BM_A_ija_eq by simp
    next
      case False note i_not_a = False
      show ?thesis
      proof (cases "i=b")
        case True
        have sum0: "sum ?f ({0..<m+n} - {a,b}) = 0"
        proof (rule sum.neutral, rule)
          fix x assume x: "x  {0..<m + n} - {a, b}"
          hence xm: "x < m+n" by auto
          have x_not_i: "x  i" using True x by blast
          have x_dr: "x < dim_row A" using x A by auto
          have "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, x) = 0"
            unfolding bezout_matrix_JNF_def 
            unfolding index_mat(1)[OF i_dr x_dr] using x_not_i x by auto
          thus "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, x) * A $$ (x, ja) = 0" by auto
        qed
        have fa: "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, a) = u" 
          unfolding bezout_matrix_JNF_def index_mat(1)[OF i_dr a_dr] using True i_not_a pquvd 
          by (auto, metis split_conv)
        have fb: "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, b) = v"
          unfolding bezout_matrix_JNF_def index_mat(1)[OF i_dr b_dr] using True i_not_a pquvd ab
          by (auto, metis split_conv)
        have "sum ?f {a,b} + sum ?f ({0..<m+n} - {a,b}) = ?f a + ?f b" using sum0 by (simp add: ab)
        also have "... = u * A $$ (a, ja) + v * A $$ (b, ja)" unfolding fa fb by simp
        also have "... = ?A $$ (i,ja)" using A True i_not_a dr i ja by auto
        finally show ?thesis using BM_A_ija_eq by simp
      next
        case False note i_not_b = False
        have sum0: "sum ?f ({0..<m+n} - {a,b} - {i}) = 0" 
        proof (rule sum.neutral, rule)
          fix x assume x: "x  {0..<m + n} - {a, b} - {i}"
          hence xm: "x < m+n" by auto
          have x_not_i: "x  i" using x by blast
          have x_dr: "x < dim_row A" using x A by auto
          have "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, x) = 0"
            unfolding bezout_matrix_JNF_def 
            unfolding index_mat(1)[OF i_dr x_dr] using x_not_i x by auto
          thus "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, x) * A $$ (x, ja) = 0" by auto
        qed
        have fa: "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, a) = 0" 
          unfolding bezout_matrix_JNF_def index_mat(1)[OF i_dr a_dr] using False i_not_a pquvd 
          by auto
        have fb: "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, b) = 0" 
          unfolding bezout_matrix_JNF_def index_mat(1)[OF i_dr b_dr] using False i_not_a pquvd 
          by auto
        have "sum ?f ({0..<m+n} - {a,b}) = sum ?f (insert i ({0..<m+n} - {a,b} - {i}))"
          by (rule sum.cong, insert i_dr A i_not_a i_not_b, auto)
        also have "... = ?f i + sum ?f ({0..<m+n} - {a,b} - {i})" by (rule sum.insert, auto)
        also have "... = ?f i" using sum0 by simp
        also have "... = ?A $$ (i,ja)"
          unfolding bezout_matrix_JNF_def using i_not_a i_not_b  A dr i ja by fastforce
        finally show ?thesis unfolding BM_A_ija_eq by (simp add: ab fa fb)
      qed    
    qed
  qed
qed




context proper_mod_operation
begin

lemma reduce_invertible_mat: 
  assumes A': "A'  carrier_mat m n" and a: "a<m" and j: "0<n" and b: "b<m" and ab: "a  b" 
  and A_def: "A = A' @r (D m (1m n))"
  and Aaj: "A $$ (a,0)  0"
  and a_less_b: "a < b"
  and mn: "mn"
  and D_ge0: "D > 0"
shows "P. invertible_mat P  P  carrier_mat (m+n) (m+n)  (reduce a b D A) = P * A" (is ?thesis1)
proof -
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(b,0))"
    by (metis prod_cases5)
  let ?A = "Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a then (p*A$$(a,k) + q*A$$(b,k))
                   else if i = b then u * A$$(a,k) + v * A$$(b,k)
                   else A$$(i,k)
            )"
  have D: "D m 1m n  carrier_mat n n" by auto
  have A: "A  carrier_mat (m+n) n" using A_def A' by simp
  hence A_carrier: "?A  carrier_mat (m+n) n" by auto

  let ?BM = "bezout_matrix_JNF A a b 0 euclid_ext2" 
  have A'_BZ_A: "?A = ?BM * A"
    by (rule bezout_matrix_JNF_mult_eq[OF A' _ _ ab A_def D pquvd], insert a b, auto)  
  have invertible_bezout: "invertible_mat ?BM"
    by (rule invertible_bezout_matrix_JNF[OF A is_bezout_ext_euclid_ext2 a_less_b _ j Aaj],
        insert a_less_b b, auto)      
  have BM: "?BM  carrier_mat (m+n) (m+n)" unfolding bezout_matrix_JNF_def using A by auto

  define xs where "xs = [0..<n]"
  let ?reduce_a = "reduce_row_mod_D ?A a xs D m"
  let ?A' = "mat_of_rows n [Matrix.row ?A i. i  [0..<m]]"
  have A_A'_D: "?A = ?A' @r D m 1m n"
  proof (rule matrix_append_rows_eq_if_preserves[OF A_carrier D], rule+)
    fix i j assume i: "i  {m..<m + n}" and j: "j < n"
    have "?A $$ (i,j) = A $$ (i,j)" using i a b A j by auto
    also have "... = (if i < dim_row A' then A' $$(i,j) else (D m (1m n))$$(i-m,j))"
      by (unfold A_def, rule append_rows_nth[OF A' D _ j], insert i, auto)
    also have "... = (D m 1m n) $$ (i - m, j)" using i A' by auto
    finally show "?A $$ (i,j) = (D m 1m n) $$ (i - m, j)" .   
  qed
  have reduce_a_eq: "?reduce_a = Matrix.mat (dim_row ?A) (dim_col ?A) 
    (λ(i, k). if i = a  k  set xs then if k = 0 then if D dvd ?A$$(i,k) then D
              else ?A $$ (i, k) else ?A $$ (i, k) gmod D else ?A $$ (i, k))"
    by (rule reduce_row_mod_D[OF A_A'_D _ a _], insert xs_def mn D_ge0, auto)  
  have reduce_a: "?reduce_a  carrier_mat (m+n) n"  using reduce_a_eq A by auto
  have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P  ?reduce_a = P * ?A"
    by (rule reduce_row_mod_D_invertible_mat[OF A_A'_D _ a], insert xs_def mn, auto)    
  from this obtain P where P: "P  carrier_mat (m + n) (m + n)" and inv_P: "invertible_mat P" 
    and reduce_a_PA: "?reduce_a = P * ?A" by blast
  define ys where "ys = [1..<n]"
  let ?reduce_b = "reduce_row_mod_D ?reduce_a b ys D m"
  let ?B' = "mat_of_rows n [Matrix.row ?reduce_a i. i  [0..<m]]"
  have reduce_a_B'_D: "?reduce_a = ?B' @r D m 1m n"
  proof (rule matrix_append_rows_eq_if_preserves[OF reduce_a D], rule+)
    fix i ja assume i: "i  {m..<m + n}" and ja: "ja < n"
    have i_not_a:"ia" and i_not_b: "ib" using i a b by auto
    have "?reduce_a $$ (i,ja) = ?A $$ (i, ja)"
      unfolding reduce_a_eq using i i_not_a i_not_b ja A by auto      
    also have "... = A $$ (i,ja)"  using i i_not_a i_not_b ja A by auto
    also have "... = (D m 1m n) $$ (i - m, ja)"
      by (smt D append_rows_nth A' A_def atLeastLessThan_iff 
          carrier_matD(1) i ja less_irrefl_nat nat_SN.compat)    
    finally show "?reduce_a $$ (i,ja) = (D m 1m n) $$ (i - m, ja)" .
  qed
  have reduce_b_eq: "?reduce_b = Matrix.mat (dim_row ?reduce_a) (dim_col ?reduce_a) 
    (λ(i, k). if i = b  k  set ys then if k = 0 then if D dvd ?reduce_a$$(i,k) then D else ?reduce_a $$ (i, k)
      else ?reduce_a $$ (i, k) gmod D else ?reduce_a $$ (i, k))"
    by (rule reduce_row_mod_D[OF reduce_a_B'_D _ b _ _ mn], unfold ys_def, insert D_ge0, auto)
  have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P  ?reduce_b = P * ?reduce_a"
    by (rule reduce_row_mod_D_invertible_mat[OF reduce_a_B'_D _ b _ mn], insert ys_def, auto)    
  from this obtain Q where Q: "Q  carrier_mat (m + n) (m + n)" and inv_Q: "invertible_mat Q" 
    and reduce_b_Q_reduce: "?reduce_b = Q * ?reduce_a" by blast
  have reduce_b_eq_reduce: "?reduce_b = (reduce a b D A)"
  proof (rule eq_matI)
    show dr_eq: "dim_row ?reduce_b = dim_row (reduce a b D A)" 
      and dc_eq: "dim_col ?reduce_b = dim_col (reduce a b D A)"
      using reduce_preserves_dimensions by auto
    fix i ja assume i: "i<dim_row (reduce a b D A)" and ja: "ja< dim_col (reduce a b D A)"
    have im: "i<m+n" using A i reduce_preserves_dimensions(1) by auto
    have ja_n: "ja<n" using A ja reduce_preserves_dimensions(2) by auto
    show "?reduce_b $$ (i,ja) = (reduce a b D A) $$ (i,ja)"
    proof (cases "(ia  ib)")
      case True
      have "?reduce_b $$ (i,ja) = ?reduce_a $$ (i,ja)" unfolding reduce_b_eq 
        by (smt True dr_eq dc_eq i index_mat(1) ja prod.simps(2) reduce_row_mod_D_preserves_dimensions)
      also have "... = ?A $$ (i,ja)"
        by (smt A True carrier_matD(2) dim_col_mat(1) dim_row_mat(1) i index_mat(1) ja_n 
            reduce_a_eq reduce_preserves_dimensions(1) split_conv)
      also have "... = A $$ (i,ja)" using A True im ja_n by auto
      also have "... = (reduce a b D A) $$ (i,ja)" unfolding reduce_alt_def_not0[OF Aaj pquvd]
        using im ja_n A True by auto
      finally show ?thesis .      
    next
      case False note a_or_b = False
      show ?thesis
      proof (cases "i=a")
        case True note ia = True
        hence i_not_b: "ib" using ab by auto
        show ?thesis
        proof -
          have ja_in_xs: "ja  set xs"
            unfolding xs_def using True ja_n im a A unfolding set_filter by auto
          have 1: "?reduce_b $$ (i,ja) = ?reduce_a $$ (i,ja)" unfolding reduce_b_eq             
            by (smt ab dc_eq dim_row_mat(1) dr_eq i ia index_mat(1) ja prod.simps(2)
                reduce_b_eq reduce_row_mod_D_preserves_dimensions(2))
          show ?thesis 
          proof (cases "ja = 0  D dvd p*A$$(a,ja) + q*A$$(b,ja)")
            case True
            have "?reduce_a $$ (i,ja) = D"
              unfolding reduce_a_eq using True ab a_or_b i_not_b ja_n im a A ja_in_xs False by auto
            also have "... = (reduce a b D A) $$ (i,ja)"
              unfolding reduce_alt_def_not0[OF Aaj pquvd]
              using True a_or_b i_not_b ja_n im A False                
              by auto 
            finally show ?thesis using 1 by simp
          next
            case False note nc1 = False
            show ?thesis
            proof (cases "ja=0")
              case True
              then show ?thesis
                by (smt (z3) "1" A assms(3) assms(7) dim_col_mat(1) dim_row_mat(1) euclid_ext2_works i ia im index_mat(1)
                    ja ja_in_xs old.prod.case pquvd reduce_gcd reduce_preserves_dimensions reduce_a_eq)
            next
              case False
              have "?reduce_a $$ (i,ja) = ?A $$ (i, ja) gmod D"
                unfolding reduce_a_eq using True ab a_or_b i_not_b ja_n im a A ja_in_xs False by auto
              also have "... = (reduce a b D A) $$ (i,ja)"
                unfolding reduce_alt_def_not0[OF Aaj pquvd] using True a_or_b i_not_b ja_n im A False by auto
              finally show ?thesis using 1 by simp
          qed    
        qed        
      qed
      next
        case False note i_not_a = False
        have i_drb: "i<dim_row ?reduce_b"
          and i_dra: "i<dim_row ?reduce_a"
          and ja_drb: "ja < dim_col ?reduce_b"
          and ja_dra: "ja < dim_col ?reduce_a" using reduce_carrier[OF A] i ja A dr_eq dc_eq by auto
          have ib: "i=b" using False a_or_b by auto
        show ?thesis
        proof (cases "ja  set  ys")
          case True note ja_in_ys = True     
          hence ja_not0: "ja  0" unfolding ys_def by auto
          have "?reduce_b $$ (i,ja) = (if ja = 0 then if D dvd ?reduce_a$$(i,ja) then D
                else ?reduce_a $$ (i, ja) else ?reduce_a $$ (i, ja) gmod D)"
            unfolding reduce_b_eq using i_not_a True  ja ja_in_ys 
            by (smt i_dra ja_dra a_or_b index_mat(1) prod.simps(2))
          also have "... = (if ja = 0 then if D dvd ?reduce_a$$(i,ja) then D else ?A $$ (i, ja) else ?A $$ (i, ja) gmod D)"
            unfolding reduce_a_eq using True ab a_or_b ib False ja_n im a A ja_in_ys by auto
          also have "... = (reduce a b D A) $$ (i,ja)"
            unfolding reduce_alt_def_not0[OF Aaj pquvd] using True ja_not0 False a_or_b ib ja_n im A 
            using i_not_a by auto                
          finally show ?thesis .
        next
          case False
          hence ja0:"ja = 0" using ja_n unfolding ys_def by auto
          have rw0: "u * A $$ (a, ja) + v * A $$ (b, ja) = 0"
            unfolding euclid_ext2_works[OF pquvd[symmetric]] ja0
            by (smt euclid_ext2_works[OF pquvd[symmetric]] more_arith_simps(11) mult.commute mult_minus_left)
          have "?reduce_b $$ (i,ja) = ?reduce_a $$ (i,ja)" unfolding reduce_b_eq             
            by (smt False a_or_b dc_eq dim_row_mat(1) dr_eq i index_mat(1) ja 
                prod.simps(2) reduce_b_eq reduce_row_mod_D_preserves_dimensions(2))
          also have "... = ?A $$ (i, ja)"
            unfolding reduce_a_eq using False ab a_or_b i_not_a ja_n im a A  by auto
          also have "... = u * A $$ (a, ja) + v * A $$ (b, ja)" 
            by (smt (verit, ccfv_SIG) A ja = 0 assms(3) assms(5) carrier_matD(2) i ib index_mat(1)
                old.prod.case reduce_preserves_dimensions(1))  
          also have "... = (reduce a b D A) $$ (i,ja)"
            unfolding reduce_alt_def_not0[OF Aaj pquvd] 
            using False a_or_b i_not_a ja_n im A ja0 by auto
          finally show ?thesis .
        qed
      qed      
    qed    
  qed
  have inv_QPBM: "invertible_mat (Q * P * ?BM)"
    by (meson BM P Q inv_P inv_Q invertible_bezout invertible_mult_JNF mult_carrier_mat)
  moreover have "(Q*P*?BM)  carrier_mat (m + n) (m + n)" using BM P Q by auto
  moreover have "(reduce a b D A) = (Q*P*?BM) * A"
  proof -
    have "?BM * A = ?A" using A'_BZ_A by auto
    hence "P * (?BM * A) = ?reduce_a" using reduce_a_PA by auto
    hence "Q * (P * (?BM * A)) = ?reduce_b" using reduce_b_Q_reduce by auto
    thus ?thesis using reduce_b_eq_reduce
      by (smt A A'_BZ_A A_carrier BM P Q assoc_mult_mat mn mult_carrier_mat reduce_a_PA)  
  qed
  ultimately show ?thesis by blast
qed


lemma reduce_abs_invertible_mat: 
  assumes A': "A'  carrier_mat m n" and a: "a<m" and j: "0<n" and b: "b<m" and ab: "a  b" 
  and A_def: "A = A' @r (D m (1m n))"
  and Aaj: "A $$ (a,0)  0"
  and a_less_b: "a < b"
  and mn: "mn"
  and D_ge0: "D > 0"
shows "P. invertible_mat P  P  carrier_mat (m+n) (m+n)  (reduce_abs a b D A) = P * A" (is ?thesis1)
proof -
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(b,0))"
    by (metis prod_cases5)
  let ?A = "Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a then (p*A$$(a,k) + q*A$$(b,k))
                   else if i = b then u * A$$(a,k) + v * A$$(b,k)
                   else A$$(i,k)
            )"
  have D: "D m 1m n  carrier_mat n n" by auto
  have A: "A  carrier_mat (m+n) n" using A_def A' by simp
  hence A_carrier: "?A  carrier_mat (m+n) n" by auto

  let ?BM = "bezout_matrix_JNF A a b 0 euclid_ext2" 
  have A'_BZ_A: "?A = ?BM * A"
    by (rule bezout_matrix_JNF_mult_eq[OF A' _ _ ab A_def D pquvd], insert a b, auto)  
  have invertible_bezout: "invertible_mat ?BM"
    by (rule invertible_bezout_matrix_JNF[OF A is_bezout_ext_euclid_ext2 a_less_b _ j Aaj],
        insert a_less_b b, auto)      
  have BM: "?BM  carrier_mat (m+n) (m+n)" unfolding bezout_matrix_JNF_def using A by auto

  define xs where "xs = filter (λi. abs (?A $$ (a,i)) > D) [0..<n]"
  let ?reduce_a = "reduce_row_mod_D_abs ?A a xs D m"
  let ?A' = "mat_of_rows n [Matrix.row ?A i. i  [0..<m]]"
  have A_A'_D: "?A = ?A' @r D m 1m n"
  proof (rule matrix_append_rows_eq_if_preserves[OF A_carrier D], rule+)
    fix i j assume i: "i  {m..<m + n}" and j: "j < n"
    have "?A $$ (i,j) = A $$ (i,j)" using i a b A j by auto
    also have "... = (if i < dim_row A' then A' $$(i,j) else (D m (1m n))$$(i-m,j))"
      by (unfold A_def, rule append_rows_nth[OF A' D _ j], insert i, auto)
    also have "... = (D m 1m n) $$ (i - m, j)" using i A' by auto
    finally show "?A $$ (i,j) = (D m 1m n) $$ (i - m, j)" .   
  qed
  have reduce_a_eq: "?reduce_a = Matrix.mat (dim_row ?A) (dim_col ?A) 
    (λ(i, k). if i = a  k  set xs then 
      if k = 0  D dvd ?A$$(i,k) then D else ?A $$ (i, k) gmod D else ?A $$ (i, k))"
    by (rule reduce_row_mod_D_abs[OF A_A'_D _ a _], insert xs_def mn D_ge0, auto)  
  have reduce_a: "?reduce_a  carrier_mat (m+n) n"  using reduce_a_eq A by auto
  have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P  ?reduce_a = P * ?A"
    by (rule reduce_row_mod_D_abs_invertible_mat[OF A_A'_D _ a], insert xs_def mn, auto)    
  from this obtain P where P: "P  carrier_mat (m + n) (m + n)" and inv_P: "invertible_mat P" 
    and reduce_a_PA: "?reduce_a = P * ?A" by blast
  define ys where "ys = filter (λi. abs (?A $$ (b,i)) > D) [0..<n]"
  let ?reduce_b = "reduce_row_mod_D_abs ?reduce_a b ys D m"
  let ?B' = "mat_of_rows n [Matrix.row ?reduce_a i. i  [0..<m]]"
  have reduce_a_B'_D: "?reduce_a = ?B' @r D m 1m n"
  proof (rule matrix_append_rows_eq_if_preserves[OF reduce_a D], rule+)
    fix i ja assume i: "i  {m..<m + n}" and ja: "ja < n"
    have i_not_a:"ia" and i_not_b: "ib" using i a b by auto
    have "?reduce_a $$ (i,ja) = ?A $$ (i, ja)"
      unfolding reduce_a_eq using i i_not_a i_not_b ja A by auto      
    also have "... = A $$ (i,ja)"  using i i_not_a i_not_b ja A by auto
    also have "... = (D m 1m n) $$ (i - m, ja)"
      by (smt D append_rows_nth A' A_def atLeastLessThan_iff 
          carrier_matD(1) i ja less_irrefl_nat nat_SN.compat)    
    finally show "?reduce_a $$ (i,ja) = (D m 1m n) $$ (i - m, ja)" .
  qed
  have reduce_b_eq: "?reduce_b = Matrix.mat (dim_row ?reduce_a) (dim_col ?reduce_a) 
    (λ(i, k). if i = b  k  set ys then if k = 0  D dvd ?reduce_a$$(i,k) then D 
      else ?reduce_a $$ (i, k) gmod D else ?reduce_a $$ (i, k))"
    by (rule reduce_row_mod_D_abs[OF reduce_a_B'_D _ b _ _ mn], unfold ys_def, insert D_ge0, auto)
  have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P  ?reduce_b = P * ?reduce_a"
    by (rule reduce_row_mod_D_abs_invertible_mat[OF reduce_a_B'_D _ b _ mn], insert ys_def, auto)    
  from this obtain Q where Q: "Q  carrier_mat (m + n) (m + n)" and inv_Q: "invertible_mat Q" 
    and reduce_b_Q_reduce: "?reduce_b = Q * ?reduce_a" by blast
  have reduce_b_eq_reduce: "?reduce_b = (reduce_abs a b D A)"
  proof (rule eq_matI)
    show dr_eq: "dim_row ?reduce_b = dim_row (reduce_abs a b D A)" 
      and dc_eq: "dim_col ?reduce_b = dim_col (reduce_abs a b D A)"
      using reduce_preserves_dimensions by auto
    fix i ja assume i: "i<dim_row (reduce_abs a b D A)" and ja: "ja< dim_col (reduce_abs a b D A)"
    have im: "i<m+n" using A i reduce_preserves_dimensions(3) by auto
    have ja_n: "ja<n" using A ja reduce_preserves_dimensions(4) by auto
    show "?reduce_b $$ (i,ja) = (reduce_abs a b D A) $$ (i,ja)"
    proof (cases "(ia  ib)")
      case True
      have "?reduce_b $$ (i,ja) = ?reduce_a $$ (i,ja)" unfolding reduce_b_eq 
        by (smt True dr_eq dc_eq i index_mat(1) ja prod.simps(2) reduce_row_mod_D_preserves_dimensions_abs)
      also have "... = ?A $$ (i,ja)"
        by (smt A True carrier_matD(2) dim_col_mat(1) dim_row_mat(1) i index_mat(1) ja_n 
            reduce_a_eq reduce_preserves_dimensions(3) split_conv)
      also have "... = A $$ (i,ja)" using A True im ja_n by auto
      also have "... = (reduce_abs a b D A) $$ (i,ja)" unfolding reduce_alt_def_not0[OF Aaj pquvd]
        using im ja_n A True by auto
      finally show ?thesis .      
    next
      case False note a_or_b = False
      show ?thesis
      proof (cases "i=a")
        case True note ia = True
        hence i_not_b: "ib" using ab by auto
        show ?thesis
        proof (cases "abs((p*A$$(a,ja) + q*A$$(b,ja))) > D")
          case True note ge_D = True
          have ja_in_xs: "ja  set xs"
            unfolding xs_def using True ja_n im a A unfolding set_filter by auto
          have 1: "?reduce_b $$ (i,ja) = ?reduce_a $$ (i,ja)" unfolding reduce_b_eq             
            by (smt ab dc_eq dim_row_mat(1) dr_eq i ia index_mat(1) ja prod.simps(2)
                reduce_b_eq reduce_row_mod_D_preserves_dimensions_abs(2))
          show ?thesis 
          proof (cases "ja = 0  D dvd p*A$$(a,ja) + q*A$$(b,ja)")
            case True
            have "?reduce_a $$ (i,ja) = D"
              unfolding reduce_a_eq using True ab a_or_b i_not_b ja_n im a A ja_in_xs False by auto
            also have "... = (reduce_abs a b D A) $$ (i,ja)"
              unfolding reduce_alt_def_not0[OF Aaj pquvd]
              using True a_or_b i_not_b ja_n im A False ge_D               
              by auto 
            finally show ?thesis using 1 by simp
          next
            case False
            have "?reduce_a $$ (i,ja) = ?A $$ (i, ja) gmod D"
              unfolding reduce_a_eq using True ab a_or_b i_not_b ja_n im a A ja_in_xs False by auto
            also have "... = (reduce_abs a b D A) $$ (i,ja)"
              unfolding reduce_alt_def_not0[OF Aaj pquvd] using True a_or_b i_not_b ja_n im A False by auto
            finally show ?thesis using 1 by simp
          qed        
        next
          case False
          have ja_in_xs: "ja  set xs"
            unfolding xs_def using False ja_n im a A unfolding set_filter by auto
          have "?reduce_b $$ (i,ja) = ?reduce_a $$ (i,ja)" unfolding reduce_b_eq             
            by (smt ab dc_eq dim_row_mat(1) dr_eq i ia index_mat(1) ja prod.simps(2)
                reduce_b_eq reduce_row_mod_D_preserves_dimensions_abs(2))
          also have "... = ?A $$ (i, ja)"
            unfolding reduce_a_eq using False ab a_or_b i_not_b ja_n im a A ja_in_xs by auto
          also have "... = (reduce_abs a b D A) $$ (i,ja)"
            unfolding reduce_alt_def_not0[OF Aaj pquvd] using False a_or_b i_not_b ja_n im A by auto
          finally show ?thesis .
        qed      
      next
        case False note i_not_a = False
        have i_drb: "i<dim_row ?reduce_b"
          and i_dra: "i<dim_row ?reduce_a"
          and ja_drb: "ja < dim_col ?reduce_b"
          and ja_dra: "ja < dim_col ?reduce_a" using reduce_carrier[OF A] i ja A dr_eq dc_eq by auto
          have ib: "i=b" using False a_or_b by auto
        show ?thesis
        proof (cases "abs((u*A$$(a,ja) + v * A$$(b,ja))) > D")
          case True note ge_D = True
          have ja_in_ys: "ja  set ys"
            unfolding ys_def using True False ib ja_n im a b A unfolding set_filter by auto
          have "?reduce_b $$ (i,ja) = (if ja = 0  D dvd ?reduce_a$$(i,ja) then D else ?reduce_a $$ (i, ja) gmod D)"          
            unfolding reduce_b_eq using i_not_a True  ja ja_in_ys 
            by (smt i_dra ja_dra a_or_b index_mat(1) prod.simps(2))
          also have "... = (if ja = 0  D dvd ?reduce_a$$(i,ja) then D else ?A $$ (i, ja) gmod D)"   
            unfolding reduce_a_eq using True ab a_or_b ib False ja_n im a A ja_in_ys by auto
          also have "... = (reduce_abs a b D A) $$ (i,ja)"
          proof (cases "ja = 0  D dvd ?reduce_a$$(i,ja)")
            case True
            have ja0: "ja=0" using True by auto
            have "u * A $$ (a, ja) + v * A $$ (b, ja) = 0"
              unfolding euclid_ext2_works[OF pquvd[symmetric]] ja0
              by (smt euclid_ext2_works[OF pquvd[symmetric]] more_arith_simps(11) mult.commute mult_minus_left)
            hence abs_0: "abs((u*A$$(a,ja) + v * A$$(b,ja))) = 0" by auto
            show ?thesis using abs_0 D_ge0 ge_D by linarith           
          next
            case False
            then show ?thesis 
              unfolding reduce_alt_def_not0[OF Aaj pquvd] using True ge_D False a_or_b ib ja_n im A 
              using i_not_a by auto           
          qed              
          finally show ?thesis .
        next
          case False
          have ja_in_ys: "ja  set ys"
            unfolding ys_def using i_not_a False ib ja_n im a b A unfolding set_filter by auto
          have "?reduce_b $$ (i,ja) = ?reduce_a $$ (i,ja)" unfolding reduce_b_eq                         
            using i_dra ja_dra ja_in_ys by auto
          also have "... = ?A $$ (i, ja)"
            unfolding reduce_a_eq using False ab a_or_b i_not_a ja_n im a A  by auto
          also have "... = u * A $$ (a, ja) + v * A $$ (b, ja)" 
            unfolding reduce_a_eq using False ab a_or_b i_not_a ja_n im a A ja_in_ys by auto            
          also have "... = (reduce_abs a b D A) $$ (i,ja)"
            unfolding reduce_alt_def_not0[OF Aaj pquvd] 
            using False a_or_b i_not_a ja_n im A by auto
          finally show ?thesis .
        qed
      qed      
    qed    
  qed
  have inv_QPBM: "invertible_mat (Q * P * ?BM)"
    by (meson BM P Q inv_P inv_Q invertible_bezout invertible_mult_JNF mult_carrier_mat)
  moreover have "(Q*P*?BM)  carrier_mat (m + n) (m + n)" using BM P Q by auto
  moreover have "(reduce_abs a b D A) = (Q*P*?BM) * A"
  proof -
    have "?BM * A = ?A" using A'_BZ_A by auto
    hence "P * (?BM * A) = ?reduce_a" using reduce_a_PA by auto
    hence "Q * (P * (?BM * A)) = ?reduce_b" using reduce_b_Q_reduce by auto
    thus ?thesis using reduce_b_eq_reduce
      by (smt A A'_BZ_A A_carrier BM P Q assoc_mult_mat mn mult_carrier_mat reduce_a_PA)  
  qed
  ultimately show ?thesis by blast
qed




lemma reduce_element_mod_D_case_m':
  assumes A_def: "A = A' @r  B" and B: "Bcarrier_mat n n"
  and A': "A'  carrier_mat m n" and a: "am" and j: "j<n" 
  and mn: "m>=n" and B1: "B $$ (j, j) = D" and B2: "(j'{0..<n}-{j}. B $$ (j, j') = 0)"
  and D0: "D > 0" 
  shows "reduce_element_mod_D A a j D m = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a  k = j then if j = 0 then if D dvd A$$(i,k) then D
                   else A$$(i,k) else A$$(i,k) gmod D else A$$(i,k))" (is "_ = ?A")
proof (rule eq_matI)
  have jm: "j<m" using mn j by auto
  have A: "A  carrier_mat (m+n) n" using A_def A' B mn by simp
  fix i ja assume i: "i < dim_row ?A" and ja: "ja < dim_col ?A"
  show "reduce_element_mod_D A a j D m $$ (i, ja) = ?A $$ (i, ja)"
 proof (cases "i=a")
    case False
    have "reduce_element_mod_D A a j D m = (if j = 0 then if D dvd A$$(a,j)
        then addrow (-((A$$(a,j) gdiv D)) + 1) a (j + m) A else A
        else addrow (-((A$$(a,j) gdiv D))) a (j + m) A)"
      unfolding reduce_element_mod_D_def by simp
    also have "... $$ (i,ja) = A $$ (i, ja)" unfolding mat_addrow_def using False ja i by auto     
    also have "... = ?A $$ (i,ja)" using False using i ja by auto
    finally show ?thesis .
  next
    case True note ia = True
    have "reduce_element_mod_D A a j D m 
      = (if j = 0 then if D dvd A$$(a,j) then addrow (-((A$$(a,j) gdiv D)) + 1) a (j + m) A else A
        else addrow (-((A$$(a,j) gdiv D))) a (j + m) A)" 
      unfolding reduce_element_mod_D_def by simp
    also have "... $$ (i,ja) = ?A $$ (i,ja)"
    proof (cases "ja = j")
      case True note ja_j = True
      have "A $$ (j + m, ja) = B $$ (j,ja)"
        by (rule append_rows_nth2[OF A' _ A_def ], insert j ja A B mn, auto)  
      also have "... = D" using True j mn B1 B2 B by auto      
      finally have A_ja_jaD: "A $$ (j + m, ja) = D" .

      show ?thesis
      proof (cases "j=0  D dvd A$$(a,j)")
        case True         
        have 1: "reduce_element_mod_D A a j D m = addrow (-((A$$(a,j) gdiv D)) + 1) a (j + m) A "
          using True ia ja_j unfolding reduce_element_mod_D_def by auto
        also have "... $$(i,ja) = (- (A $$ (a, j) gdiv D) + 1) * A $$ (j + m, ja) + A $$ (i, ja)"
          unfolding mat_addrow_def using True ja_j ia
          using A i j by auto
        also have "... = D"
        proof -
          have "A $$ (i, ja) + D * - (A $$ (i, ja) gdiv D) = 0"
            using True ia ja_j using D0 by force
          then show ?thesis
            by (metis A_ja_jaD ab_semigroup_add_class.add_ac(1) add.commute add_right_imp_eq ia int_distrib(2)
                ja_j more_arith_simps(3) mult.commute mult_cancel_right1)
        qed   
        also have "... = ?A $$ (i,ja)" using True ia A i j ja_j by auto
        finally show ?thesis
          using True 1 by auto
      next
        case False
        show ?thesis
        proof (cases "j=0")
          case True
          then show ?thesis 
            using False i ja by auto
        next
          case False
          have "?A $$ (i,ja) = A $$ (i, ja) gmod D" using True ia A i j False by auto
          also have "... = A $$ (i, ja) - ((A $$ (i, ja) gdiv D) * D)"
            by (subst gmod_gdiv[OF D0], auto)
          also have "... =  - (A $$ (a, j) gdiv D) * A $$ (j + m, ja) + A $$ (i, ja)"
            unfolding A_ja_jaD by (simp add: True ia)
          finally show ?thesis 
            using A False True i ia j by auto
      qed
    qed
    next
      case False
      have "A $$ (j + m, ja) = B $$ (j,ja)"
        by (rule append_rows_nth2[OF A' _ A_def ], insert j mn ja A B, auto)
      also have "... = 0" using False using A a mn ja j B2 by force        
      finally have A_am_ja0: "A $$ (j + m, ja) = 0" .
      then show ?thesis using False i ja by fastforce
    qed
    finally show ?thesis .
  qed
next
  show "dim_row (reduce_element_mod_D A a j D m) = dim_row ?A" 
    and "dim_col (reduce_element_mod_D A a j D m) = dim_col ?A"
    using reduce_element_mod_D_def by auto
qed




lemma reduce_element_mod_D_abs_case_m':
  assumes A_def: "A = A' @r  B" and B: "Bcarrier_mat n n"
  and A': "A'  carrier_mat m n" and a: "am" and j: "j<n" 
  and mn: "m>=n" and B1: "B $$ (j, j) = D" and B2: "(j'{0..<n}-{j}. B $$ (j, j') = 0)"
  and D0: "D > 0" 
  shows "reduce_element_mod_D_abs A a j D m = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a  k = j then if j = 0  D dvd A$$(i,k) then D else A$$(i,k) gmod D else A$$(i,k))" (is "_ = ?A")
proof (rule eq_matI)
  have jm: "j<m" using mn j by auto
  have A: "A  carrier_mat (m+n) n" using A_def A' B mn by simp
  fix i ja assume i: "i < dim_row ?A" and ja: "ja < dim_col ?A"
  show "reduce_element_mod_D_abs A a j D m $$ (i, ja) = ?A $$ (i, ja)"
 proof (cases "i=a")
    case False
    have "reduce_element_mod_D_abs A a j D m = (if j = 0  D dvd A$$(a,j)
        then addrow (-((A$$(a,j) gdiv D)) + 1) a (j + m) A
        else addrow (-((A$$(a,j) gdiv D))) a (j + m) A)"
      unfolding reduce_element_mod_D_abs_def by simp
    also have "... $$ (i,ja) = A $$ (i, ja)" unfolding mat_addrow_def using False ja i by auto     
    also have "... = ?A $$ (i,ja)" using False using i ja by auto
    finally show ?thesis .
  next
    case True note ia = True
    have "reduce_element_mod_D_abs A a j D m 
      = (if j = 0  D dvd A$$(a,j) then addrow (-((A$$(a,j) gdiv D)) + 1) a (j + m) A
        else addrow (-((A$$(a,j) gdiv D))) a (j + m) A)" 
      unfolding reduce_element_mod_D_abs_def by simp
    also have "... $$ (i,ja) = ?A $$ (i,ja)"
    proof (cases "ja = j")
      case True note ja_j = True
      have "A $$ (j + m, ja) = B $$ (j,ja)"
        by (rule append_rows_nth2[OF A' _ A_def ], insert j ja A B mn, auto)  
      also have "... = D" using True j mn B1 B2 B by auto      
      finally have A_ja_jaD: "A $$ (j + m, ja) = D" .

      show ?thesis
      proof (cases "j=0  D dvd A$$(a,j)")
        case True         
        have 1: "reduce_element_mod_D_abs A a j D m = addrow (-((A$$(a,j) gdiv D)) + 1) a (j + m) A "
          using True ia ja_j unfolding reduce_element_mod_D_abs_def by auto
        also have "... $$(i,ja) = (- (A $$ (a, j) gdiv D) + 1) * A $$ (j + m, ja) + A $$ (i, ja)"
          unfolding mat_addrow_def using True ja_j ia
          using A i j by auto
        also have "... = D"
        proof -
          have "A $$ (i, ja) + D * - (A $$ (i, ja) gdiv D) = 0"
            using True ia ja_j using D0 by force
          then show ?thesis
            by (metis A_ja_jaD ab_semigroup_add_class.add_ac(1) add.commute add_right_imp_eq ia int_distrib(2)
                ja_j more_arith_simps(3) mult.commute mult_cancel_right1)
        qed   
        also have "... = ?A $$ (i,ja)" using True ia A i j ja_j by auto
        finally show ?thesis
          using True 1 by auto
      next
        case False        
          have "?A $$ (i,ja) = A $$ (i, ja) gmod D" using True ia A i j False by auto
          also have "... = A $$ (i, ja) - ((A $$ (i, ja) gdiv D) * D)"
            by (subst gmod_gdiv[OF D0], auto)
          also have "... =  - (A $$ (a, j) gdiv D) * A $$ (j + m, ja) + A $$ (i, ja)"
            unfolding A_ja_jaD by (simp add: True ia)
          finally show ?thesis 
            using A False True i ia j by auto
        qed    
    next
      case False
      have "A $$ (j + m, ja) = B $$ (j,ja)"
        by (rule append_rows_nth2[OF A' _ A_def ], insert j mn ja A B, auto)
      also have "... = 0" using False using A a mn ja j B2 by force        
      finally have A_am_ja0: "A $$ (j + m, ja) = 0" .
      then show ?thesis using False i ja by fastforce
    qed
    finally show ?thesis .
  qed
next
  show "dim_row (reduce_element_mod_D_abs A a j D m) = dim_row ?A" 
    and "dim_col (reduce_element_mod_D_abs A a j D m) = dim_col ?A"
    using reduce_element_mod_D_abs_def by auto
qed


lemma reduce_row_mod_D_case_m':
  assumes A_def: "A = A' @r B" and "B  carrier_mat n n"
    and A': "A'  carrier_mat m n" and "a < m" 
    and j: "jset xs. j<n  (B $$ (j, j) = D)  (j'{0..<n}-{j}. B $$ (j, j') = 0)" 
    and d: "distinct xs" and "mn"
    and D: "D > 0" 
  shows "reduce_row_mod_D A a xs D m = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a  k  set xs then if k = 0 then if D dvd A$$(i,k) then D
                   else A$$(i,k) else A$$(i,k) gmod D else A$$(i,k))"
  using assms
proof (induct A a xs D m arbitrary: A' B rule: reduce_row_mod_D.induct)
  case (1 A a D m)
  then show ?case by force
next
  case (2 A a x xs D m)
  note A_A'B = "2.prems"(1)
  note B = "2.prems"(2)
  note A' = "2.prems"(3)
  note a = "2.prems"(4)
  note j = "2.prems"(5)
  note mn = "2.prems"(7)
  note d = "2.prems"(6)
  let ?reduce_xs = "(reduce_element_mod_D A a x D m)"
  have reduce_xs_carrier: "?reduce_xs  carrier_mat (m + n) n"
    by (metis "2.prems"(1) "2.prems"(2) "2.prems"(3) add.right_neutral append_rows_def 
            carrier_matD carrier_mat_triv index_mat_four_block(2,3) index_zero_mat(2,3)
            reduce_element_mod_D_preserves_dimensions)
  have 1: "reduce_row_mod_D A a (x # xs) D m 
    = reduce_row_mod_D ?reduce_xs a xs D m" by simp
  have 2: "reduce_element_mod_D A a j D m = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a  k = j then if j = 0 then if D dvd A$$(i,k) 
          then D else A$$(i,k) else A$$(i,k) gmod D else A$$(i,k))" if "jset (x#xs)" for j
    by (rule reduce_element_mod_D_case_m'[OF A_A'B B A'], insert "2.prems" that, auto)
  have "reduce_row_mod_D ?reduce_xs a xs D m =
    Matrix.mat (dim_row ?reduce_xs) (dim_col ?reduce_xs) (λ(i,k). if i = a  k  set xs 
    then if k = 0 then if D dvd ?reduce_xs $$ (i, k) then D else ?reduce_xs $$ (i, k) else
    ?reduce_xs $$ (i, k) gmod D else ?reduce_xs $$ (i, k))"
  proof (rule "2.hyps"[OF _ B _ a _ _ mn])
    let ?A' = "mat_of_rows n [Matrix.row (reduce_element_mod_D A a x D m) i. i  [0..<m]]"
    show "reduce_element_mod_D A a x D m = ?A' @r B"
    proof (rule matrix_append_rows_eq_if_preserves[OF reduce_xs_carrier B])
      show " i{m..<m + n}. j<n. reduce_element_mod_D A a x D m $$ (i, j) = B $$ (i - m, j) "       
        by (smt A_A'B A' B a Metric_Arith.nnf_simps(7) add_diff_cancel_left' atLeastLessThan_iff
            carrier_matD index_mat_addrow(1) index_row(1) le_add_diff_inverse2 less_diff_conv
            reduce_element_mod_D_def reduce_element_mod_D_preserves_dimensions reduce_xs_carrier
            row_append_rows2)        
    qed
  qed (insert "2.prems", auto simp add: mat_of_rows_def)
  also have "... = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a  k  set (x # xs) then if k = 0 then if D dvd A$$(i,k)
          then D else A$$(i,k) else A$$(i,k) gmod D else A$$(i,k))" (is "?lhs = ?rhs")
  proof (rule eq_matI) 
    show "dim_row ?lhs = dim_row ?rhs" and "dim_col ?lhs = dim_col ?rhs" by auto
    fix i j assume i: "i<dim_row ?rhs" and j: "j < dim_col ?rhs"
    have jn: "j<n" using j "2.prems" by (simp add: append_rows_def)
    have xn: "x < n" 
      by (simp add: "2.prems"(5))
    show "?lhs $$ (i,j) = ?rhs $$ (i,j)"
    proof (cases "i=a  j  set xs")
      case True note ia_jxs = True
      have j_not_x: "jx" using d True by auto
      show ?thesis
      proof (cases "j=0  D dvd ?reduce_xs $$(i,j)")
        case True
        have "?lhs $$ (i,j) = D"
          using True i j ia_jxs by auto
        also have "... = ?rhs $$ (i,j)" using i j j_not_x 
          by (smt "2" calculation dim_col_mat(1) dim_row_mat(1) index_mat(1) insert_iff list.set(2) prod.simps(2) xn)
        finally show ?thesis .
      next
        case False
        show ?thesis
        proof (cases "j=0")
          case True
          then show ?thesis
            by (smt (z3) "2" dim_col_mat(1) dim_row_mat(1) i index_mat(1) insert_iff j list.set(2) old.prod.case)
        next
          case False
          have "?lhs $$ (i,j) = ?reduce_xs $$ (i, j) gmod D"
            using True False i j by auto
          also have "... = A $$ (i,j) gmod D" using 2[OF ] j_not_x i j by auto
          also have "... = ?rhs $$ (i,j)" using i j j_not_x 
            using False True dim_col_mat(1) dim_row_mat(1) index_mat(1) 
              list.set_intros(2) old.prod.case by auto
          finally show ?thesis .
        qed
    qed
  next
      case False
      show ?thesis using 2 i j xn 
        by (smt False dim_col_mat(1) dim_row_mat(1) index_mat(1) insert_iff list.set(2) prod.simps(2))
    qed   
  qed  
  finally show ?case using 1 by simp
qed




lemma reduce_row_mod_D_abs_case_m':
  assumes A_def: "A = A' @r B" and "B  carrier_mat n n"
    and A': "A'  carrier_mat m n" and "a < m" 
    and j: "jset xs. j<n  (B $$ (j, j) = D)  (j'{0..<n}-{j}. B $$ (j, j') = 0)" 
    and d: "distinct xs" and "mn"
    and D: "D > 0" 
  shows "reduce_row_mod_D_abs A a xs D m = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a  k  set xs then if k = 0  D dvd A$$(i,k) then D
                   else A$$(i,k) gmod D else A$$(i,k))"
  using assms
proof (induct A a xs D m arbitrary: A' B rule: reduce_row_mod_D_abs.induct)
  case (1 A a D m)
  then show ?case by force
next
  case (2 A a x xs D m)
  note A_A'B = "2.prems"(1)
  note B = "2.prems"(2)
  note A' = "2.prems"(3)
  note a = "2.prems"(4)
  note j = "2.prems"(5)
  note mn = "2.prems"(7)
  note d = "2.prems"(6)
  let ?reduce_xs = "(reduce_element_mod_D_abs A a x D m)"
  have reduce_xs_carrier: "?reduce_xs  carrier_mat (m + n) n"
    by (metis "2.prems"(1) "2.prems"(2) "2.prems"(3) add.right_neutral append_rows_def 
            carrier_matD carrier_mat_triv index_mat_four_block(2,3) index_zero_mat(2,3)
            reduce_element_mod_D_preserves_dimensions)
  have 1: "reduce_row_mod_D_abs A a (x # xs) D m 
    = reduce_row_mod_D_abs ?reduce_xs a xs D m" by simp
  have 2: "reduce_element_mod_D_abs A a j D m = Matrix.mat (dim_row A) (dim_col A)
           (λ(i,k). if i = a  k = j then if j = 0  D dvd A$$(i,k) 
            then D else A$$(i,k) gmod D else A$$(i,k))" if "jset (x#xs)" for j
    by (rule reduce_element_mod_D_abs_case_m'[OF A_A'B B A'], insert "2.prems" that, auto)
  have "reduce_row_mod_D_abs ?reduce_xs a xs D m =
    Matrix.mat (dim_row ?reduce_xs) (dim_col ?reduce_xs) (λ(i,k). if i = a  k  set xs 
    then if k = 0  D dvd ?reduce_xs $$ (i, k) then D else
    ?reduce_xs $$ (i, k) gmod D else ?reduce_xs $$ (i, k))"
  proof (rule "2.hyps"[OF _ B _ a _ _ mn])
    let ?A' = "mat_of_rows n [Matrix.row (reduce_element_mod_D_abs A a x D m) i. i  [0..<m]]"
    show "reduce_element_mod_D_abs A a x D m = ?A' @r B"
    proof (rule matrix_append_rows_eq_if_preserves[OF reduce_xs_carrier B])
      show " i{m..<m + n}. j<n. reduce_element_mod_D_abs A a x D m $$ (i, j) = B $$ (i - m, j) "       
        by (smt A_A'B A' B a Metric_Arith.nnf_simps(7) add_diff_cancel_left' atLeastLessThan_iff
            carrier_matD index_mat_addrow(1) index_row(1) le_add_diff_inverse2 less_diff_conv
            reduce_element_mod_D_abs_def reduce_element_mod_D_preserves_dimensions reduce_xs_carrier
            row_append_rows2)        
    qed
  qed (insert "2.prems", auto simp add: mat_of_rows_def)
  also have "... = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a  k  set (x # xs) then if k = 0  D dvd A$$(i,k)
          then D else A$$(i,k) gmod D else A$$(i,k))" (is "?lhs = ?rhs")
  proof (rule eq_matI) 
    show "dim_row ?lhs = dim_row ?rhs" and "dim_col ?lhs = dim_col ?rhs" by auto
    fix i j assume i: "i<dim_row ?rhs" and j: "j < dim_col ?rhs"
    have jn: "j<n" using j "2.prems" by (simp add: append_rows_def)
    have xn: "x < n" 
      by (simp add: "2.prems"(5))
    show "?lhs $$ (i,j) = ?rhs $$ (i,j)"
    proof (cases "i=a  j  set xs")
      case True note ia_jxs = True
      have j_not_x: "jx" using d True by auto
      show ?thesis
      proof (cases "j=0  D dvd ?reduce_xs $$(i,j)")
        case True
        have "?lhs $$ (i,j) = D"
          using True i j ia_jxs by auto
        also have "... = ?rhs $$ (i,j)" using i j j_not_x 
          by (smt "2" calculation dim_col_mat(1) dim_row_mat(1) index_mat(1) insert_iff list.set(2) prod.simps(2) xn)
        finally show ?thesis .
      next
        case False        
        have "?lhs $$ (i,j) = ?reduce_xs $$ (i, j) gmod D"
         using True False i j by auto
       also have "... = A $$ (i,j) gmod D" using 2[OF ] j_not_x i j by auto
       also have "... = ?rhs $$ (i,j)" using i j j_not_x
         by (smt False True ‹Matrix.mat (dim_row ?reduce_xs) 
           (dim_col ?reduce_xs) (λ(i, k). if i = a  k  set xs 
           then if k = 0  D dvd  ?reduce_xs $$ (i, k) 
           then D else  ?reduce_xs $$ (i, k) gmod D 
           else  ?reduce_xs $$ (i, k)) $$ (i, j) =  ?reduce_xs $$ (i, j) gmod D 
               calculation dim_col_mat(1) dim_row_mat(1) dvd_imp_gmod_0[OF D > 0] index_mat(1) 
               insert_iff list.set(2) gmod_0_imp_dvd prod.simps(2))
       finally show ?thesis .
     qed   
  next
      case False
      show ?thesis using 2 i j xn 
        by (smt False dim_col_mat(1) dim_row_mat(1) index_mat(1) insert_iff list.set(2) prod.simps(2))
    qed   
  qed  
  finally show ?case using 1 by simp
qed



lemma
  assumes A_def: "A = A' @r B" and B: "B  carrier_mat n n"
  and A': "A'  carrier_mat m n" and a: "a<m" and j: "j<n" and mn: "mn"
shows reduce_element_mod_D_invertible_mat_case_m: 
  "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  reduce_element_mod_D A a j D m = P * A" (is ?thesis1)
  and reduce_element_mod_D_abs_invertible_mat_case_m:
  "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  
      reduce_element_mod_D_abs A a j D m = P * A" (is ?thesis2)
  unfolding atomize_conj
proof (rule conjI; cases "j = 0  D dvd A$$(a,j)")
  case True
  let ?P = "addrow_mat (m+n) (- (A $$ (a, j) gdiv D) + 1) a (j + m)"
  have A: "A  carrier_mat (m + n) n" using A_def A' B mn by auto
  have "reduce_element_mod_D_abs A a j D m =  addrow (- (A $$ (a, j) gdiv D) + 1) a (j + m) A"
    unfolding reduce_element_mod_D_abs_def using True by auto
  also have "... = ?P * A" by (rule addrow_mat[OF A], insert j mn, auto)
  finally have rw: "reduce_element_mod_D_abs A a j D m = ?P * A" .
  have "reduce_element_mod_D A a j D m =  addrow (- (A $$ (a, j) gdiv D) + 1) a (j + m) A"
    unfolding reduce_element_mod_D_def using True by auto
  also have "... = ?P * A" by (rule addrow_mat[OF A], insert j mn, auto)
  finally have "reduce_element_mod_D A a j D m = ?P * A" .
  moreover have "?P  carrier_mat (m+n) (m+n)" by simp
  moreover have "invertible_mat ?P"
    by (metis addrow_mat_carrier a det_addrow_mat dvd_mult_right 
        invertible_iff_is_unit_JNF mult.right_neutral not_add_less2 semiring_gcd_class.gcd_dvd1)
  ultimately show ?thesis1 and ?thesis2 using rw by blast+
next
  case False
  show ?thesis1
  proof (cases "j=0")
    case True
    have "reduce_element_mod_D A a j D m = A" unfolding reduce_element_mod_D_def using False True by auto
    then show ?thesis
      by (metis A_def assms(2) assms(3) carrier_append_rows invertible_mat_one left_mult_one_mat one_carrier_mat)
  next
    case False
    let ?P = "addrow_mat (m+n) (- (A $$ (a, j) gdiv D)) a (j + m)"
    have A: "A  carrier_mat (m + n) n" using A_def B A' mn by auto
    have "reduce_element_mod_D A a j D m =  addrow (- (A $$ (a, j) gdiv D)) a (j + m) A"
      unfolding reduce_element_mod_D_def using False by auto
    also have "... = ?P * A" by (rule addrow_mat[OF A], insert j mn, auto)
    finally have "reduce_element_mod_D A a j D m = ?P * A" .
    moreover have "?P  carrier_mat (m+n) (m+n)" by simp
    moreover have "invertible_mat ?P"
      by (metis addrow_mat_carrier a det_addrow_mat dvd_mult_right 
          invertible_iff_is_unit_JNF mult.right_neutral not_add_less2 semiring_gcd_class.gcd_dvd1)
    ultimately show ?thesis by blast
  qed
  show ?thesis2
  proof -
    let ?P = "addrow_mat (m+n) (- (A $$ (a, j) gdiv D)) a (j + m)"
    have A: "A  carrier_mat (m + n) n" using A_def B A' mn by auto
    have "reduce_element_mod_D_abs A a j D m =  addrow (- (A $$ (a, j) gdiv D)) a (j + m) A"
      unfolding reduce_element_mod_D_abs_def using False by auto
    also have "... = ?P * A" by (rule addrow_mat[OF A], insert j mn, auto)
    finally have "reduce_element_mod_D_abs A a j D m = ?P * A" .
    moreover have "?P  carrier_mat (m+n) (m+n)" by simp
    moreover have "invertible_mat ?P"
      by (metis addrow_mat_carrier a det_addrow_mat dvd_mult_right 
          invertible_iff_is_unit_JNF mult.right_neutral not_add_less2 semiring_gcd_class.gcd_dvd1)
    ultimately show ?thesis by blast
  qed
qed


lemma reduce_row_mod_D_invertible_mat_case_m:
  assumes A_def: "A = A' @r B" and "B  carrier_mat n n"
    and A': "A'  carrier_mat m n" and a: "a < m" 
    and j: "jset xs. j<n  (B $$ (j, j) = D)  (j'{0..<n}-{j}. B $$ (j, j') = 0)" 
    and mn: "mn"
  shows "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  
    reduce_row_mod_D A a xs D m = P * A"
  using assms
proof (induct A a xs D m arbitrary: A' B rule: reduce_row_mod_D.induct)
  case (1 A a D m)
  show ?case by (rule exI[of _ "1m (m+n)"], insert "1.prems", auto simp add: append_rows_def)
next
  case (2 A a x xs D m)
  note A_def = "2.prems"(1)
  note B = "2.prems"(2)
  note A' = "2.prems"(3)
  note a = "2.prems"(4)
  note j = "2.prems"(5)
  note mn = "2.prems"(6)  
  let ?reduce_xs = "(reduce_element_mod_D A a x D m)"
  have 1: "reduce_row_mod_D A a (x # xs) D m 
    = reduce_row_mod_D ?reduce_xs a xs D m" by simp
  have "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  
    reduce_element_mod_D A a x D m = P * A" 
    by (rule reduce_element_mod_D_invertible_mat_case_m, insert "2.prems", auto)
  from this obtain P where P: "P  carrier_mat (m+n) (m+n)" and inv_P: "invertible_mat P"
    and R_P: "reduce_element_mod_D A a x D m = P * A" by auto
  have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P 
       reduce_row_mod_D ?reduce_xs a xs D m = P * ?reduce_xs"
  proof (rule "2.hyps")
    let ?A' = "mat_of_rows n [Matrix.row ?reduce_xs i. i  [0..<m]]"
    let ?B' = "mat_of_rows n [Matrix.row ?reduce_xs i. i  [m..<m+n]]"

    show reduce_xs_A'B': "?reduce_xs = ?A' @r ?B'"
      by (smt "2"(2) "2"(4) P R_P add.comm_neutral append_rows_def append_rows_split carrier_matD
          index_mat_four_block(3) index_mult_mat(2) index_zero_mat(3) le_add1 reduce_element_mod_D_preserves_dimensions(2))
    show "jset xs. j < n  ?B' $$ (j, j) = D  (j'{0..<n} - {j}. ?B' $$ (j, j') = 0)"
    proof
      fix j assume j_in_xs: "j  set xs"
      have jn: "j<n" using j_in_xs j by auto
      have "?B' $$ (j, j) = ?reduce_xs $$ (m+j,j)"
        by (smt "2"(7) Groups.add_ac(2) jn reduce_xs_A'B' add_diff_cancel_left' append_rows_nth2
            diff_zero length_map length_upt mat_of_rows_carrier(1) nat_SN.compat)
      also have "... = B $$ (j,j)" 
        by (smt "2"(2) "2"(5) A' P R_P add_diff_cancel_left' append_rows_def carrier_matD
            group_cancel.rule0 index_mat_addrow(1) index_mat_four_block(1) index_mat_four_block(2,3)
            index_mult_mat(2) index_zero_mat(3) jn le_add1 linorder_not_less nat_SN.plus_gt_right_mono 
            reduce_element_mod_D_def reduce_element_mod_D_preserves_dimensions(1))
      also have "... = D" using j j_in_xs by auto
      finally have B'_jj: "?B' $$ (j, j) = D" by auto
      moreover have "j'{0..<n} - {j}. ?B' $$ (j, j') = 0" 
      proof 
        fix j' assume j': "j' {0..<n} - {j}"
        have "?B' $$ (j, j') = ?reduce_xs $$ (m+j,j')"
          by (smt mn Diff_iff j' add.commute add_diff_cancel_left' 
              append_rows_nth2 atLeastLessThan_iff diff_zero jn length_map length_upt 
              mat_of_rows_carrier(1) nat_SN.compat reduce_xs_A'B')
        also have "... = B $$ (j,j')"
          by (smt "2"(2) "2"(5) A' Diff_iff P R_P j' add.commute add_diff_cancel_left'  
            append_rows_def atLeastLessThan_iff carrier_matD group_cancel.rule0 index_mat_addrow(1)
            index_mat_four_block index_mult_mat(2) index_zero_mat(3) jn nat_SN.plus_gt_right_mono 
            not_add_less2 reduce_element_mod_D_def reduce_element_mod_D_preserves_dimensions(1))
        also have "... = 0" using j j_in_xs j' by auto
        finally show "?B' $$ (j, j') = 0" .
      qed
      ultimately show "j < n  ?B' $$ (j, j) = D  (j'{0..<n} - {j}. ?B' $$ (j, j') = 0)"
        using jn by blast
    qed
    show "?A' : carrier_mat m n" by auto      
    show "?B' : carrier_mat n n" by auto
    show "a<m" using "2.prems" by auto
    show "nm" using "2.prems" by auto    
  qed
  from this obtain P2 where P2: "P2  carrier_mat (m + n) (m + n)" and inv_P2: "invertible_mat P2"
    and R_P2: "reduce_row_mod_D ?reduce_xs a xs D m = P2 * ?reduce_xs"
    by auto
  have "invertible_mat (P2 * P)" using P P2 inv_P inv_P2 invertible_mult_JNF by blast
  moreover have "(P2 * P)  carrier_mat (m+n) (m+n)" using P2 P by auto
  moreover have "reduce_row_mod_D A a (x # xs) D m = (P2 * P) * A" 
    by (smt P P2 R_P R_P2 1 assoc_mult_mat carrier_matD carrier_mat_triv
        index_mult_mat reduce_row_mod_D_preserves_dimensions)
  ultimately show ?case by blast
qed




lemma reduce_row_mod_D_abs_invertible_mat_case_m:
  assumes A_def: "A = A' @r B" and "B  carrier_mat n n"
    and A': "A'  carrier_mat m n" and a: "a < m" 
    and j: "jset xs. j<n  (B $$ (j, j) = D)  (j'{0..<n}-{j}. B $$ (j, j') = 0)" 
    and mn: "mn"
  shows "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  
    reduce_row_mod_D_abs A a xs D m = P * A"
  using assms
proof (induct A a xs D m arbitrary: A' B rule: reduce_row_mod_D_abs.induct)
  case (1 A a D m)
  show ?case by (rule exI[of _ "1m (m+n)"], insert "1.prems", auto simp add: append_rows_def)
next
  case (2 A a x xs D m)
  note A_def = "2.prems"(1)
  note B = "2.prems"(2)
  note A' = "2.prems"(3)
  note a = "2.prems"(4)
  note j = "2.prems"(5)
  note mn = "2.prems"(6)  
  let ?reduce_xs = "(reduce_element_mod_D_abs A a x D m)"
  have 1: "reduce_row_mod_D_abs A a (x # xs) D m 
    = reduce_row_mod_D_abs ?reduce_xs a xs D m" by simp
  have "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  
    reduce_element_mod_D_abs A a x D m = P * A" 
    by (rule reduce_element_mod_D_abs_invertible_mat_case_m, insert "2.prems", auto)
  from this obtain P where P: "P  carrier_mat (m+n) (m+n)" and inv_P: "invertible_mat P"
    and R_P: "reduce_element_mod_D_abs A a x D m = P * A" by auto
  have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P 
       reduce_row_mod_D_abs ?reduce_xs a xs D m = P * ?reduce_xs"
  proof (rule "2.hyps")
    let ?A' = "mat_of_rows n [Matrix.row ?reduce_xs i. i  [0..<m]]"
    let ?B' = "mat_of_rows n [Matrix.row ?reduce_xs i. i  [m..<m+n]]"

    show reduce_xs_A'B': "?reduce_xs = ?A' @r ?B'"
      by (smt "2"(2) "2"(4) P R_P add.comm_neutral append_rows_def append_rows_split carrier_matD
          index_mat_four_block(3) index_mult_mat(2) index_zero_mat(3) le_add1 reduce_element_mod_D_preserves_dimensions(4))
    show "jset xs. j < n  ?B' $$ (j, j) = D  (j'{0..<n} - {j}. ?B' $$ (j, j') = 0)"
    proof
      fix j assume j_in_xs: "j  set xs"
      have jn: "j<n" using j_in_xs j by auto
      have "?B' $$ (j, j) = ?reduce_xs $$ (m+j,j)"
        by (smt "2"(7) Groups.add_ac(2) jn reduce_xs_A'B' add_diff_cancel_left' append_rows_nth2
            diff_zero length_map length_upt mat_of_rows_carrier(1) nat_SN.compat)
      also have "... = B $$ (j,j)" 
        by (smt "2"(2) "2"(5) A' P R_P add_diff_cancel_left' append_rows_def carrier_matD
            group_cancel.rule0 index_mat_addrow(1) index_mat_four_block(1) index_mat_four_block(2,3)
            index_mult_mat(2) index_zero_mat(3) jn le_add1 linorder_not_less nat_SN.plus_gt_right_mono 
            reduce_element_mod_D_abs_def reduce_element_mod_D_preserves_dimensions(3))
      also have "... = D" using j j_in_xs by auto
      finally have B'_jj: "?B' $$ (j, j) = D" by auto
      moreover have "j'{0..<n} - {j}. ?B' $$ (j, j') = 0" 
      proof 
        fix j' assume j': "j' {0..<n} - {j}"
        have "?B' $$ (j, j') = ?reduce_xs $$ (m+j,j')"
          by (smt mn Diff_iff j' add.commute add_diff_cancel_left' 
              append_rows_nth2 atLeastLessThan_iff diff_zero jn length_map length_upt 
              mat_of_rows_carrier(1) nat_SN.compat reduce_xs_A'B')
        also have "... = B $$ (j,j')"
          by (smt "2"(2) "2"(5) A' Diff_iff P R_P j' add.commute add_diff_cancel_left'  
            append_rows_def atLeastLessThan_iff carrier_matD group_cancel.rule0 index_mat_addrow(1)
            index_mat_four_block index_mult_mat(2) index_zero_mat(3) jn nat_SN.plus_gt_right_mono 
            not_add_less2 reduce_element_mod_D_abs_def reduce_element_mod_D_preserves_dimensions(3))
        also have "... = 0" using j j_in_xs j' by auto
        finally show "?B' $$ (j, j') = 0" .
      qed
      ultimately show "j < n  ?B' $$ (j, j) = D  (j'{0..<n} - {j}. ?B' $$ (j, j') = 0)"
        using jn by blast
    qed
    show "?A' : carrier_mat m n" by auto      
    show "?B' : carrier_mat n n" by auto
    show "a<m" using "2.prems" by auto
    show "nm" using "2.prems" by auto    
  qed
  from this obtain P2 where P2: "P2  carrier_mat (m + n) (m + n)" and inv_P2: "invertible_mat P2"
    and R_P2: "reduce_row_mod_D_abs ?reduce_xs a xs D m = P2 * ?reduce_xs"
    by auto
  have "invertible_mat (P2 * P)" using P P2 inv_P inv_P2 invertible_mult_JNF by blast
  moreover have "(P2 * P)  carrier_mat (m+n) (m+n)" using P2 P by auto
  moreover have "reduce_row_mod_D_abs A a (x # xs) D m = (P2 * P) * A" 
    by (smt P P2 R_P R_P2 1 assoc_mult_mat carrier_matD carrier_mat_triv
        index_mult_mat reduce_row_mod_D_preserves_dimensions_abs)
  ultimately show ?case by blast
qed




(*Similar to thm reduce_row_mod_D_case_m' but including the case a = m. 
This could substitute the previous version.*)
lemma reduce_row_mod_D_case_m'':
  assumes A_def: "A = A' @r B" and "B  carrier_mat n n"
    and A': "A'  carrier_mat m n" and "a  m" 
    and j: "jset xs. j<n  (B $$ (j, j) = D)  (j'{0..<n}-{j}. B $$ (j, j') = 0)" 
    and d: "distinct xs" and "mn" and "0  set xs"
    and "D > 0" 
  shows "reduce_row_mod_D A a xs D m = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a  k  set xs then if k = 0 then if D dvd A$$(i,k) then D
                    else A$$(i,k) else A$$(i,k) gmod D else A$$(i,k))"
  using assms
proof (induct A a xs D m arbitrary: A' B rule: reduce_row_mod_D.induct)
  case (1 A a D m)
  then show ?case by force
next
  case (2 A a x xs D m)
  note A_A'B = "2.prems"(1)
  note B = "2.prems"(2)
  note A' = "2.prems"(3)
  note a = "2.prems"(4)
  note j = "2.prems"(5)
  note mn = "2.prems"(7)
  note d = "2.prems"(6)
  note zero_not_xs = "2.prems"(8)
  let ?reduce_xs = "(reduce_element_mod_D A a x D m)"
  have reduce_xs_carrier: "?reduce_xs  carrier_mat (m + n) n"
    by (metis "2.prems"(1) "2.prems"(2) "2.prems"(3) add.right_neutral append_rows_def 
            carrier_matD carrier_mat_triv index_mat_four_block(2,3) index_zero_mat(2,3)
            reduce_element_mod_D_preserves_dimensions)
  have A: "A:carrier_mat (m+n) n" using A' B A_A'B by blast
  have 1: "reduce_row_mod_D A a (x # xs) D m 
    = reduce_row_mod_D ?reduce_xs a xs D m" by simp
  have 2: "reduce_element_mod_D A a j D m = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a  k = j then if j = 0 then if D dvd A$$(i,k)
          then D else A$$(i,k) else A$$(i,k) gmod D else A$$(i,k))" if "jset (x#xs)" for j
    by (rule reduce_element_mod_D_case_m'[OF A_A'B B A'], insert "2.prems" that, auto)
  have "reduce_row_mod_D ?reduce_xs a xs D m =
    Matrix.mat (dim_row ?reduce_xs) (dim_col ?reduce_xs) (λ(i,k). if i = a  k  set xs 
    then if k=0 then if D dvd ?reduce_xs $$ (i, k) then D else ?reduce_xs $$ (i, k)
    else ?reduce_xs $$ (i, k) gmod D else ?reduce_xs $$ (i, k))"
  proof (rule "2.hyps"[OF _ _ _ a _ _ mn])
    let ?A' = "mat_of_rows n [Matrix.row (reduce_element_mod_D A a x D m) i. i  [0..<m]]"
    define B' where "B' = mat_of_rows n [Matrix.row ?reduce_xs i. i  [m..<dim_row A]]"
    show A'': "?A' : carrier_mat m n" by auto
    show B': "B' : carrier_mat n n" unfolding B'_def using mn A by auto 
    show reduce_split: "?reduce_xs = ?A' @r B'" 
      by (metis B'_def append_rows_split carrier_matD
          reduce_element_mod_D_preserves_dimensions(1) reduce_xs_carrier le_add1)
    show "jset xs. j<n  (B' $$ (j, j) = D)  (j'{0..<n}-{j}. B' $$ (j, j') = 0)"
    proof 
      fix j assume j_xs: "jset xs"
      have "B $$ (j,j') = B' $$ (j,j')" if j': "j'<n" for j'
      proof -
        have "B $$ (j,j') = A $$ (m+j,j')"
          by (smt A_A'B A A' Groups.add_ac(2) j_xs add_diff_cancel_left' append_rows_def carrier_matD j'
              index_mat_four_block(1) index_mat_four_block(2,3) insert_iff j less_diff_conv list.set(2) not_add_less1)
        also have "... = ?reduce_xs $$ (m+j,j')"
          by (smt (verit, ccfv_threshold) A'' diff_add_zero index_mat_addrow(3) neq0_conv
              a j zero_not_xs A add.commute add_diff_cancel_left' reduce_element_mod_D_def
              cancel_comm_monoid_add_class.diff_cancel carrier_matD index_mat_addrow(1) j'
              j_xs le_eq_less_or_eq less_diff_conv less_not_refl2 list.set_intros(2) nat_SN.compat)
        also have "... = B'$$ (j,j')"
          by (smt B A A' A_A'B B' A'' reduce_split add.commute add_diff_cancel_left' j' not_add_less1
              append_rows_def carrier_matD index_mat_four_block j j_xs less_diff_conv list.set_intros(2))
        finally show ?thesis .
      qed
      thus "j < n  B' $$ (j, j) = D  (j'{0..<n} - {j}. B' $$ (j, j') = 0)" using j
        by (metis Diff_iff atLeastLessThan_iff insert_iff j_xs list.simps(15))
    qed          
  qed (insert "2.prems", auto simp add: mat_of_rows_def)
  also have "... = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a  k  set (x # xs) then if k = 0 then if D dvd A$$(i,k) 
          then D else A$$(i,k) else A$$(i,k) gmod D else A$$(i,k))" (is "?lhs = ?rhs")
  proof (rule eq_matI) 
    show "dim_row ?lhs = dim_row ?rhs" and "dim_col ?lhs = dim_col ?rhs" by auto
    fix i j assume i: "i<dim_row ?rhs" and j: "j < dim_col ?rhs"
    have jn: "j<n" using j "2.prems" by (simp add: append_rows_def)
    have xn: "x < n" 
      by (simp add: "2.prems"(5))
    show "?lhs $$ (i,j) = ?rhs $$ (i,j)"
    proof (cases "i=a  j  set xs")
      case True note ia_jxs = True
      have j_not_x: "jx" using d True by auto
      show ?thesis
      proof (cases "j=0  D dvd ?reduce_xs $$(i,j)")
        case True
        have "?lhs $$ (i,j) = D"
          using True i j ia_jxs by auto
        also have "... = ?rhs $$ (i,j)" using i j j_not_x
          by (metis "2.prems"(8) True ia_jxs list.set_intros(2))
        finally show ?thesis .
      next
        case False   
        show ?thesis
          by (smt (z3) "2" "2.prems"(8) dim_col_mat(1) dim_row_mat(1) i index_mat(1) insert_iff j j_not_x list.set(2) old.prod.case)     
    qed
  next
      case False
      show ?thesis using 2 i j xn
        by (smt (z3) "2.prems"(8) False carrier_matD(2) dim_row_mat(1) index_mat(1) 
            insert_iff jn list.set(2) old.prod.case reduce_element_mod_D_preserves_dimensions(2) reduce_xs_carrier)
    qed   
  qed  
  finally show ?case using 1 by simp
qed




(*Similar to thm reduce_row_mod_D_abs_case_m' but including the case a = m. 
This could substitute the previous version.*)
lemma reduce_row_mod_D_abs_case_m'':
  assumes A_def: "A = A' @r B" and "B  carrier_mat n n"
    and A': "A'  carrier_mat m n" and "a  m" 
    and j: "jset xs. j<n  (B $$ (j, j) = D)  (j'{0..<n}-{j}. B $$ (j, j') = 0)" 
    and d: "distinct xs" and "mn" and "0  set xs"
    and "D > 0" 
  shows "reduce_row_mod_D_abs A a xs D m = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a  k  set xs then if k = 0  D dvd A$$(i,k) then D
                   else A$$(i,k) gmod D else A$$(i,k))"
  using assms
proof (induct A a xs D m arbitrary: A' B rule: reduce_row_mod_D_abs.induct)
  case (1 A a D m)
  then show ?case by force
next
  case (2 A a x xs D m)
  note A_A'B = "2.prems"(1)
  note B = "2.prems"(2)
  note A' = "2.prems"(3)
  note a = "2.prems"(4)
  note j = "2.prems"(5)
  note mn = "2.prems"(7)
  note d = "2.prems"(6)
  note zero_not_xs = "2.prems"(8)
  let ?reduce_xs = "(reduce_element_mod_D_abs A a x D m)"
  have reduce_xs_carrier: "?reduce_xs  carrier_mat (m + n) n"
    by (metis "2.prems"(1) "2.prems"(2) "2.prems"(3) add.right_neutral append_rows_def 
            carrier_matD carrier_mat_triv index_mat_four_block(2,3) index_zero_mat(2,3)
            reduce_element_mod_D_preserves_dimensions)
  have A: "A:carrier_mat (m+n) n" using A' B A_A'B by blast
  have 1: "reduce_row_mod_D_abs A a (x # xs) D m 
    = reduce_row_mod_D_abs ?reduce_xs a xs D m" by simp
  have 2: "reduce_element_mod_D_abs A a j D m = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a  k = j then if j = 0  D dvd A$$(i,k)
          then D else A$$(i,k) gmod D else A$$(i,k))" if "jset (x#xs)" for j
    by (rule reduce_element_mod_D_abs_case_m'[OF A_A'B B A'], insert "2.prems" that, auto)
  have "reduce_row_mod_D_abs ?reduce_xs a xs D m =
    Matrix.mat (dim_row ?reduce_xs) (dim_col ?reduce_xs) (λ(i,k). if i = a  k  set xs 
    then if k=0  D dvd ?reduce_xs $$ (i, k) then D 
    else ?reduce_xs $$ (i, k) gmod D else ?reduce_xs $$ (i, k))"
  proof (rule "2.hyps"[OF _ _ _ a _ _ mn])
    let ?A' = "mat_of_rows n [Matrix.row (reduce_element_mod_D_abs A a x D m) i. i  [0..<m]]"
    define B' where "B' = mat_of_rows n [Matrix.row ?reduce_xs i. i  [m..<dim_row A]]"
    show A'': "?A' : carrier_mat m n" by auto
    show B': "B' : carrier_mat n n" unfolding B'_def using mn A by auto 
    show reduce_split: "?reduce_xs = ?A' @r B'" 
      by (metis B'_def append_rows_split carrier_matD
          reduce_element_mod_D_preserves_dimensions(3) reduce_xs_carrier le_add1)
    show "jset xs. j<n  (B' $$ (j, j) = D)  (j'{0..<n}-{j}. B' $$ (j, j') = 0)"
    proof 
      fix j assume j_xs: "jset xs"
      have "B $$ (j,j') = B' $$ (j,j')" if j': "j'<n" for j'
      proof -
        have "B $$ (j,j') = A $$ (m+j,j')"
          by (smt A_A'B A A' Groups.add_ac(2) j_xs add_diff_cancel_left' append_rows_def carrier_matD j'
              index_mat_four_block(1) index_mat_four_block(2,3) insert_iff j less_diff_conv list.set(2) not_add_less1)
        also have "... = ?reduce_xs $$ (m+j,j')"
          by (smt (verit, ccfv_threshold) A'' diff_add_zero index_mat_addrow(3) neq0_conv
              a j zero_not_xs A add.commute add_diff_cancel_left' reduce_element_mod_D_abs_def
              cancel_comm_monoid_add_class.diff_cancel carrier_matD index_mat_addrow(1) j'
              j_xs le_eq_less_or_eq less_diff_conv less_not_refl2 list.set_intros(2) nat_SN.compat)
        also have "... = B'$$ (j,j')"
          by (smt B A A' A_A'B B' A'' reduce_split add.commute add_diff_cancel_left' j' not_add_less1
              append_rows_def carrier_matD index_mat_four_block j j_xs less_diff_conv list.set_intros(2))
        finally show ?thesis .
      qed
      thus "j < n  B' $$ (j, j) = D  (j'{0..<n} - {j}. B' $$ (j, j') = 0)" using j
        by (metis Diff_iff atLeastLessThan_iff insert_iff j_xs list.simps(15))
    qed          
  qed (insert "2.prems", auto simp add: mat_of_rows_def)
  also have "... = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a  k  set (x # xs) then if k = 0 then if D dvd A$$(i,k) 
          then D else A$$(i,k) else A$$(i,k) gmod D else A$$(i,k))" (is "?lhs = ?rhs")
  proof (rule eq_matI) 
    show "dim_row ?lhs = dim_row ?rhs" and "dim_col ?lhs = dim_col ?rhs" by auto
    fix i j assume i: "i<dim_row ?rhs" and j: "j < dim_col ?rhs"
    have jn: "j<n" using j "2.prems" by (simp add: append_rows_def)
    have xn: "x < n" 
      by (simp add: "2.prems"(5))
    show "?lhs $$ (i,j) = ?rhs $$ (i,j)"
    proof (cases "i=a  j  set xs")
      case True note ia_jxs = True
      have j_not_x: "jx" using d True by auto
      show ?thesis
      proof (cases "j=0  D dvd ?reduce_xs $$(i,j)")
        case True
        have "?lhs $$ (i,j) = D"
          using True i j ia_jxs by auto
        also have "... = ?rhs $$ (i,j)" using i j j_not_x
          by (metis "2.prems"(8) True ia_jxs list.set_intros(2))
        finally show ?thesis .
      next
        case False   
        show ?thesis
          by (smt (z3) "2" "2.prems"(8) dim_col_mat(1) dim_row_mat(1) i index_mat(1) insert_iff j j_not_x list.set(2) old.prod.case)     
    qed
  next
      case False
      show ?thesis using 2 i j xn
        by (smt (z3) "2.prems"(8) False carrier_matD(2) dim_row_mat(1) index_mat(1) 
            insert_iff jn list.set(2) old.prod.case reduce_element_mod_D_preserves_dimensions(4) reduce_xs_carrier)
    qed   
  qed  
  finally show ?case using 1
    by (smt (verit, ccfv_SIG) "2.prems"(8) cong_mat split_conv)
qed



lemma
  assumes A_def: "A = A' @r B" and B: "B  carrier_mat n n"
  and A': "A'  carrier_mat m n" and a: "am" and j: "j<n" and mn: "mn" and j0: "j0"
shows reduce_element_mod_D_invertible_mat_case_m':
  "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  reduce_element_mod_D A a j D m = P * A" (is ?thesis1)
  and reduce_element_mod_D_abs_invertible_mat_case_m': 
  "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  reduce_element_mod_D_abs A a j D m = P * A" (is ?thesis2)
proof -
  let ?P = "addrow_mat (m+n) (- (A $$ (a, j) gdiv D)) a (j + m)"
  have jm: "j+m a" using j0 a by auto
  have A: "A  carrier_mat (m + n) n" using A_def A' B mn by auto
  have rw: "reduce_element_mod_D A a j D m = reduce_element_mod_D_abs A a j D m" 
    unfolding reduce_element_mod_D_def reduce_element_mod_D_abs_def using j0 by auto
  have "reduce_element_mod_D A a j D m =  addrow (- (A $$ (a, j) gdiv D)) a (j + m) A"
    unfolding reduce_element_mod_D_def using j0 by auto
  also have "... = ?P * A" by (rule addrow_mat[OF A], insert j mn, auto)
  finally have "reduce_element_mod_D A a j D m = ?P * A" .
  moreover have "?P  carrier_mat (m+n) (m+n)" by simp
  moreover have "invertible_mat ?P"
    by (metis addrow_mat_carrier det_addrow_mat dvd_mult_right jm
        invertible_iff_is_unit_JNF mult.right_neutral semiring_gcd_class.gcd_dvd1)
  ultimately show ?thesis1 and ?thesis2 using rw by metis+
qed

(*Similar to reduce_row_mod_D_invertible_mat_case_m but including the case a = m, and then
adding the assumption 0 not in set xs.*)
lemma reduce_row_mod_D_invertible_mat_case_m':
  assumes A_def: "A = A' @r B" and "B  carrier_mat n n"
    and A': "A'  carrier_mat m n" and a: "a  m" 
    and j: "jset xs. j<n  (B $$ (j, j) = D)  (j'{0..<n}-{j}. B $$ (j, j') = 0)" 
    and d: "distinct xs" and mn: "mn" and "0 set xs"
  shows "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  
    reduce_row_mod_D A a xs D m = P * A"
  using assms
proof (induct A a xs D m arbitrary: A' B rule: reduce_row_mod_D.induct)
  case (1 A a D m)
  show ?case by (rule exI[of _ "1m (m+n)"], insert "1.prems", auto simp add: append_rows_def)
next
  case (2 A a x xs D m)
  note A_A'B = "2.prems"(1)
  note B = "2.prems"(2)
  note A' = "2.prems"(3)
  note a = "2.prems"(4)
  note j = "2.prems"(5)
  note mn = "2.prems"(7)
  note d = "2.prems"(6)
  note zero_not_xs = "2.prems"(8)
  let ?reduce_xs = "(reduce_element_mod_D A a x D m)"
  have reduce_xs_carrier: "?reduce_xs  carrier_mat (m + n) n"
    by (metis "2.prems"(1) "2.prems"(2) "2.prems"(3) add.right_neutral append_rows_def 
            carrier_matD carrier_mat_triv index_mat_four_block(2,3) index_zero_mat(2,3)
            reduce_element_mod_D_preserves_dimensions)
  have A: "A:carrier_mat (m+n) n" using A' B A_A'B by blast 
  let ?reduce_xs = "(reduce_element_mod_D A a x D m)"
  have 1: "reduce_row_mod_D A a (x # xs) D m 
    = reduce_row_mod_D ?reduce_xs a xs D m" by simp
  have "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  
    reduce_element_mod_D A a x D m = P * A"
    by (rule reduce_element_mod_D_invertible_mat_case_m'[OF A_A'B B A' a _ mn],
        insert zero_not_xs j, auto)
  from this obtain P where P: "P  carrier_mat (m+n) (m+n)" and inv_P: "invertible_mat P"
    and R_P: "reduce_element_mod_D A a x D m = P * A" by auto
  have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P 
       reduce_row_mod_D ?reduce_xs a xs D m = P * ?reduce_xs"
  proof (rule "2.hyps")
    let ?A' = "mat_of_rows n [Matrix.row ?reduce_xs i. i  [0..<m]]"
    let ?B' = "mat_of_rows n [Matrix.row ?reduce_xs i. i  [m..<m+n]]"
    show B': "?B'  carrier_mat n n" by auto
    show A'': "?A' : carrier_mat m n" by auto
    show reduce_split: "?reduce_xs = ?A' @r ?B'"
      by (smt "2"(2) "2"(4) P R_P add.comm_neutral append_rows_def append_rows_split carrier_matD
          index_mat_four_block(3) index_mult_mat(2) index_zero_mat(3) le_add1 reduce_element_mod_D_preserves_dimensions(2))
    show "jset xs. j < n  ?B' $$ (j, j) = D  (j'{0..<n} - {j}. ?B' $$ (j, j') = 0)"
    proof
      fix j assume j_xs: "jset xs"
      have "B $$ (j,j') = ?B' $$ (j,j')" if j': "j'<n" for j'
      proof -
        have "B $$ (j,j') = A $$ (m+j,j')"
          by (smt A_A'B A A' Groups.add_ac(2) j_xs add_diff_cancel_left' append_rows_def carrier_matD j'
              index_mat_four_block(1) index_mat_four_block(2,3) insert_iff j less_diff_conv list.set(2) not_add_less1)
        also have "... = ?reduce_xs $$ (m+j,j')"
          by (smt (verit, ccfv_SIG) not_add_less1
              a j zero_not_xs A add.commute add_diff_cancel_left' reduce_element_mod_D_def
              cancel_comm_monoid_add_class.diff_cancel carrier_matD index_mat_addrow(1) j'
              j_xs le_eq_less_or_eq less_diff_conv less_not_refl2 list.set_intros(2) nat_SN.compat)
        also have "... = ?B'$$ (j,j')"
          by (smt B A A' A_A'B B' A'' reduce_split add.commute add_diff_cancel_left' j' not_add_less1
              append_rows_def carrier_matD index_mat_four_block j j_xs less_diff_conv list.set_intros(2))
        finally show ?thesis .
      qed
      thus "j < n  ?B' $$ (j, j) = D  (j'{0..<n} - {j}. ?B' $$ (j, j') = 0)" using j
        by (metis Diff_iff atLeastLessThan_iff insert_iff j_xs list.simps(15))
    qed        
  qed (insert d zero_not_xs a mn, auto)
  from this obtain P2 where P2: "P2  carrier_mat (m + n) (m + n)" and inv_P2: "invertible_mat P2"
    and R_P2: "reduce_row_mod_D ?reduce_xs a xs D m = P2 * ?reduce_xs"
    by auto
  have "invertible_mat (P2 * P)" using P P2 inv_P inv_P2 invertible_mult_JNF by blast
  moreover have "(P2 * P)  carrier_mat (m+n) (m+n)" using P2 P by auto
  moreover have "reduce_row_mod_D A a (x # xs) D m = (P2 * P) * A" 
    by (smt P P2 R_P R_P2 1 assoc_mult_mat carrier_matD carrier_mat_triv
        index_mult_mat reduce_row_mod_D_preserves_dimensions)
  ultimately show ?case by blast
qed



lemma reduce_row_mod_D_abs_invertible_mat_case_m':
  assumes A_def: "A = A' @r B" and "B  carrier_mat n n"
    and A': "A'  carrier_mat m n" and a: "a  m" 
    and j: "jset xs. j<n  (B $$ (j, j) = D)  (j'{0..<n}-{j}. B $$ (j, j') = 0)" 
    and d: "distinct xs" and mn: "mn" and "0 set xs"
  shows "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  
    reduce_row_mod_D_abs A a xs D m = P * A"
  using assms
proof (induct A a xs D m arbitrary: A' B rule: reduce_row_mod_D_abs.induct)
  case (1 A a D m)
  show ?case by (rule exI[of _ "1m (m+n)"], insert "1.prems", auto simp add: append_rows_def)
next
  case (2 A a x xs D m)
  note A_A'B = "2.prems"(1)
  note B = "2.prems"(2)
  note A' = "2.prems"(3)
  note a = "2.prems"(4)
  note j = "2.prems"(5)
  note mn = "2.prems"(7)
  note d = "2.prems"(6)
  note zero_not_xs = "2.prems"(8)
  let ?reduce_xs = "(reduce_element_mod_D_abs A a x D m)"
  have reduce_xs_carrier: "?reduce_xs  carrier_mat (m + n) n"
    by (metis "2.prems"(1) "2.prems"(2) "2.prems"(3) add.right_neutral append_rows_def 
            carrier_matD carrier_mat_triv index_mat_four_block(2,3) index_zero_mat(2,3)
            reduce_element_mod_D_preserves_dimensions)
  have A: "A:carrier_mat (m+n) n" using A' B A_A'B by blast 
  let ?reduce_xs = "(reduce_element_mod_D_abs A a x D m)"
  have 1: "reduce_row_mod_D_abs A a (x # xs) D m 
    = reduce_row_mod_D_abs ?reduce_xs a xs D m" by simp
  have "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  
    reduce_element_mod_D_abs A a x D m = P * A"
    by (rule reduce_element_mod_D_abs_invertible_mat_case_m'[OF A_A'B B A' a _ mn],
        insert zero_not_xs j, auto)
  from this obtain P where P: "P  carrier_mat (m+n) (m+n)" and inv_P: "invertible_mat P"
    and R_P: "reduce_element_mod_D_abs A a x D m = P * A" by auto
  have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P 
       reduce_row_mod_D_abs ?reduce_xs a xs D m = P * ?reduce_xs"
  proof (rule "2.hyps")
    let ?A' = "mat_of_rows n [Matrix.row ?reduce_xs i. i  [0..<m]]"
    let ?B' = "mat_of_rows n [Matrix.row ?reduce_xs i. i  [m..<m+n]]"
    show B': "?B'  carrier_mat n n" by auto
    show A'': "?A' : carrier_mat m n" by auto
    show reduce_split: "?reduce_xs = ?A' @r ?B'"
      by (smt "2"(2) "2"(4) P R_P add.comm_neutral append_rows_def append_rows_split carrier_matD
          index_mat_four_block(3) index_mult_mat(2) index_zero_mat(3) le_add1 reduce_element_mod_D_preserves_dimensions(4))
    show "jset xs. j < n  ?B' $$ (j, j) = D  (j'{0..<n} - {j}. ?B' $$ (j, j') = 0)"
    proof
      fix j assume j_xs: "jset xs"
      have "B $$ (j,j') = ?B' $$ (j,j')" if j': "j'<n" for j'
      proof -
        have "B $$ (j,j') = A $$ (m+j,j')"
          by (smt A_A'B A A' Groups.add_ac(2) j_xs add_diff_cancel_left' append_rows_def carrier_matD j'
              index_mat_four_block(1) index_mat_four_block(2,3) insert_iff j less_diff_conv list.set(2) not_add_less1)
        also have "... = ?reduce_xs $$ (m+j,j')"
          by (smt (verit, ccfv_SIG) not_add_less1
              a j zero_not_xs A add.commute add_diff_cancel_left' reduce_element_mod_D_abs_def
              cancel_comm_monoid_add_class.diff_cancel carrier_matD index_mat_addrow(1) j'
              j_xs le_eq_less_or_eq less_diff_conv less_not_refl2 list.set_intros(2) nat_SN.compat)
        also have "... = ?B'$$ (j,j')"
          by (smt B A A' A_A'B B' A'' reduce_split add.commute add_diff_cancel_left' j' not_add_less1
              append_rows_def carrier_matD index_mat_four_block j j_xs less_diff_conv list.set_intros(2))
        finally show ?thesis .
      qed
      thus "j < n  ?B' $$ (j, j) = D  (j'{0..<n} - {j}. ?B' $$ (j, j') = 0)" using j
        by (metis Diff_iff atLeastLessThan_iff insert_iff j_xs list.simps(15))
    qed        
  qed (insert d zero_not_xs a mn, auto)
  from this obtain P2 where P2: "P2  carrier_mat (m + n) (m + n)" and inv_P2: "invertible_mat P2"
    and R_P2: "reduce_row_mod_D_abs ?reduce_xs a xs D m = P2 * ?reduce_xs"
    by auto
  have "invertible_mat (P2 * P)" using P P2 inv_P inv_P2 invertible_mult_JNF by blast
  moreover have "(P2 * P)  carrier_mat (m+n) (m+n)" using P2 P by auto
  moreover have "reduce_row_mod_D_abs A a (x # xs) D m = (P2 * P) * A" 
    by (smt P P2 R_P R_P2 1 assoc_mult_mat carrier_matD carrier_mat_triv
        index_mult_mat reduce_row_mod_D_preserves_dimensions_abs)
  ultimately show ?case by blast
qed


lemma reduce_invertible_mat_case_m: 
  assumes A': "A'  carrier_mat m n" and B: "B  carrier_mat n n"
    and a: "a<m" and ab: "a  m" 
  and A_def: "A = A' @r B"
    and j: "jset xs. j<n  (B $$ (j, j) = D)  (j'{0..<n}-{j}. B $$ (j, j') = 0)"  
  and Aaj: "A $$ (a,0)  0"
  and mn: "mn"
  and n0: "0<n"
  and pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(m,0))"
  and A2_def: "A2 = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a then (p*A$$(a,k) + q*A$$(m,k))
                   else if i = m then u * A$$(a,k) + v * A$$(m,k)
                   else A$$(i,k)
            )"
  and xs_def: "xs = [1..<n]"
  and ys_def: "ys = [1..<n]"
    and j_ys: "jset ys. j<n  (B $$ (j, j) = D)  (j'{0..<n}-{j}. B $$ (j, j') = 0)"
    and D0: "D > 0"
  and Am0_D: "A $$ (m, 0)  {0,D}"
  and Am0_D2: "A $$ (m, 0) = 0  A $$ (a, 0) = D"
shows "P. invertible_mat P  P  carrier_mat (m+n) (m+n)  (reduce a m D A) = P * A"
proof -
  let ?A = "Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a then (p*A$$(a,k) + q*A$$(m,k))
                   else if i = m then u * A$$(a,k) + v * A$$(m,k)
                   else A$$(i,k)
            )"
  have D: "D m 1m n  carrier_mat n n" using mn by auto
  have A: "A  carrier_mat (m+n) n" using A_def A' B mn by simp
  hence A_carrier: "?A  carrier_mat (m+n) n" by auto

  let ?BM = "bezout_matrix_JNF A a m 0 euclid_ext2"
  
  have A'_BZ_A: "?A = ?BM * A"
    by (rule bezout_matrix_JNF_mult_eq[OF A' _ _ ab A_def B pquvd], insert a, auto)  
  have invertible_bezout: "invertible_mat ?BM"
    by (rule invertible_bezout_matrix_JNF[OF A is_bezout_ext_euclid_ext2 a _ _ Aaj], insert a n0, auto)      
  have BM: "?BM  carrier_mat (m+n) (m+n)" unfolding bezout_matrix_JNF_def using A by auto
  let ?reduce_a = "reduce_row_mod_D ?A a xs D m"
  define A'1 where "A'1 = mat_of_rows n [Matrix.row ?A i. i  [0..<m]]"
  define A'2 where "A'2 = mat_of_rows n [Matrix.row ?A i. i  [m..<dim_row A]]"
  have A_A'_D: "?A = A'1 @r A'2" using append_rows_split A
    by (metis (no_types, lifting) A'1_def A'2_def A_carrier carrier_matD le_add1)
  have j_A'1_A'2: "jset xs. j < n  A'2 $$ (j, j) = D  (j'{0..<n} - {j}. A'2 $$ (j, j') = 0)"
    proof (rule ballI)
      fix ja assume ja: "jaset xs"
      have ja_n: "ja < n" using ja unfolding xs_def by auto
      have ja2: "ja < dim_row A - m" using A mn ja_n by auto
      have ja_m: "ja < m" using ja_n mn by auto
      have ja_not_0: "ja  0" using ja unfolding xs_def by auto
      show "ja < n  A'2 $$ (ja, ja) = D  (j'{0..<n} - {ja}. A'2 $$ (ja, j') = 0)"
      proof -
        have "A'2 $$ (ja, ja) = [Matrix.row ?A i. i  [m..<dim_row A]] ! ja $v ja"
          by (metis (no_types, lifting) A A'2_def add_diff_cancel_left' carrier_matD(1) 
              ja_n length_map length_upt mat_of_rows_index)
        also have "... = ?A $$ (m + ja, ja)" using A mn ja_n by auto
        also have "... = A $$ (m+ja, ja)" using A a mn ja_n ja_not_0 by auto
        also have "... =  (A' @r B) $$ (m + ja, ja)" unfolding A_def ..
        also have "... = B $$ (ja, ja)"
          by (metis B Groups.add_ac(2) append_rows_nth2 assms(1) ja_n mn nat_SN.compat)
        also have "... = D" using j ja by blast
        finally have A2_D: "A'2 $$ (ja, ja) = D" .

        moreover have "(j'{0..<n} - {ja}. A'2 $$ (ja, j') = 0)"
        proof (rule ballI)
          fix j' assume j': "j': {0..<n} - {ja}"
          have "A'2 $$ (ja, j') = [Matrix.row ?A i. i  [m..<dim_row A]] ! ja $v j'"
            unfolding A'2_def by (rule mat_of_rows_index, insert j' ja_n ja2, auto)
          also have "... = ?A $$ (m + ja, j')" using A mn ja_n j' by auto
          also have "... = A $$ (m+ja, j')" using A a mn ja_n ja_not_0 j' by auto
          also have "... =  (A' @r B) $$ (ja + m, j')" unfolding A_def
            by (simp add: add.commute)
          also have "... = B $$ (ja, j')"
            by (rule append_rows_nth2[OF A' B _ ja_m ja_n], insert j', auto)
          also have "... = 0" using mn j' ja_n j ja by auto
          finally show "A'2 $$ (ja, j') = 0" .
        qed
        ultimately show ?thesis using ja_n by simp
      qed
    qed
  have reduce_a_eq: "?reduce_a = Matrix.mat (dim_row ?A) (dim_col ?A) 
    (λ(i, k). if i = a  k  set xs then if k = 0 then if D dvd ?A $$ (i, k) then D
    else ?A $$ (i, k) else ?A $$ (i, k) gmod D else ?A $$ (i, k))"
  proof (rule reduce_row_mod_D_case_m'[OF A_A'_D _ _ a j_A'1_A'2 _ mn D0])    
    show "A'2  carrier_mat n n" using A A'2_def by auto
    show "A'1  carrier_mat m n" by (simp add: A'1_def mat_of_rows_def) 
    show "distinct xs" using distinct_filter distinct_upt xs_def by blast
  qed
  have reduce_a: "?reduce_a  carrier_mat (m+n) n" using reduce_a_eq A by auto
  have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P  ?reduce_a = P * ?A"
    by (rule reduce_row_mod_D_invertible_mat_case_m[OF A_A'_D _ _ _ j_A'1_A'2 mn],
        insert a A A'2_def A'1_def, auto)
  from this obtain P where P: "P  carrier_mat (m + n) (m + n)" and inv_P: "invertible_mat P" 
    and reduce_a_PA: "?reduce_a = P * ?A" by blast
  let ?reduce_b = "reduce_row_mod_D ?reduce_a m ys D m"
  let ?B' = "mat_of_rows n [Matrix.row ?reduce_a i. i  [0..<m]]"
  define reduce_a1 where "reduce_a1 = mat_of_rows (dim_col ?reduce_a) [Matrix.row ?reduce_a i. i  [0..<m]]"
  define reduce_a2 where "reduce_a2 = mat_of_rows (dim_col ?reduce_a) [Matrix.row ?reduce_a i. i  [m..<dim_row ?reduce_a]]"
  have reduce_a_split: "?reduce_a = reduce_a1 @r reduce_a2"
    by (unfold reduce_a1_def reduce_a2_def, rule append_rows_split, insert mn A, auto)  
  have zero_notin_ys: "0  set ys"
  proof -
    have m: "m<dim_row A" using A n0 by auto
    have "?A $$ (m,0) =  u * A $$ (a, 0) + v * A $$ (m, 0)" using m n0 a A by auto
    also have "... = 0" using pquvd
      by (smt dvd_mult_div_cancel euclid_ext2_def euclid_ext2_works(3) more_arith_simps(11)
          mult.commute mult_minus_left prod.sel(1) prod.sel(2) semiring_gcd_class.gcd_dvd1)
    finally show ?thesis using D0 unfolding ys_def by auto
  qed
  have reduce_a2: "reduce_a2  carrier_mat n n" unfolding reduce_a2_def using A by auto
  have reduce_a1: "reduce_a1  carrier_mat m n" unfolding reduce_a1_def using A by auto
  have j2: "jset ys. j < n  reduce_a2 $$ (j, j) = D  (j'{0..<n} - {j}. reduce_a2 $$ (j, j') = 0)"
  proof
    fix j assume j_in_ys: "j  set ys"
    have a_jm: "a  j+m" using a by auto
    have m_not_jm: "m  j + m" using zero_notin_ys j_in_ys by fastforce
    have jm: "j+m < dim_row ?A" using A_carrier j_in_ys unfolding ys_def by auto
    have jn: "j < dim_col ?A" using A_carrier j_in_ys unfolding ys_def by auto
    have jm': "j+m < dim_row A" using A_carrier j_in_ys unfolding ys_def by auto
    have jn': "j < dim_col A" using A_carrier j_in_ys unfolding ys_def by auto
    have "reduce_a2 $$ (j, j') = B $$ (j,j')" if j': "j'<n" for j'
    proof -
      have "reduce_a2 $$ (j, j') = ?reduce_a $$ (j+m,j')"
        by (rule append_rows_nth2[symmetric, OF reduce_a1 reduce_a2 reduce_a_split],
            insert j_in_ys mn j', auto simp add: ys_def)
      also have "... = ?A $$ (j+m, j')" using reduce_a_eq jm jn a_jm j' A_carrier by auto          
      also have "... = A $$ (j+m, j')" using a_jm m_not_jm jm' jn' j' A_carrier by auto
      also have "... = B $$ (j,j')"
        by (smt A append_rows_nth2 A' B A_def mn carrier_matD(2) jn' le_Suc_ex that trans_less_add1)
      finally show ?thesis .
    qed
    thus "j < n  reduce_a2 $$ (j, j) = D  (j'{0..<n} - {j}. reduce_a2 $$ (j, j') = 0)"
      using j_ys j_in_ys by auto
  qed
  have reduce_b_eq: "?reduce_b = Matrix.mat (dim_row ?reduce_a) (dim_col ?reduce_a) 
    (λ(i, k). if i = m  k  set ys then if k = 0 then if D dvd ?reduce_a $$ (i, k) then D
      else ?reduce_a $$ (i, k) else ?reduce_a $$ (i, k) gmod D else ?reduce_a $$ (i, k))"
    by (rule reduce_row_mod_D_case_m''[OF reduce_a_split reduce_a2 reduce_a1 _ j2 _ mn zero_notin_ys],
        insert D0, auto simp add: ys_def)    
  have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P  ?reduce_b = P * ?reduce_a"
    by (rule reduce_row_mod_D_invertible_mat_case_m'[OF reduce_a_split reduce_a2 reduce_a1 _ j2 _ mn zero_notin_ys],
        auto simp add: ys_def) 
  from this obtain Q where Q: "Q  carrier_mat (m + n) (m + n)" and inv_Q: "invertible_mat Q" 
    and reduce_b_Q_reduce: "?reduce_b = Q * ?reduce_a" by blast
  have reduce_b_eq_reduce: "?reduce_b = (reduce a m D A)"
  proof (rule eq_matI)
    show dr_eq: "dim_row ?reduce_b = dim_row (reduce a m D A)" 
      and dc_eq: "dim_col ?reduce_b = dim_col (reduce a m D A)"
      using reduce_preserves_dimensions by auto
    fix i ja assume i: "i<dim_row (reduce a m D A)" and ja: "ja< dim_col (reduce a m D A)"
    have im: "i<m+n" using A i reduce_preserves_dimensions(1) by auto
    have ja_n: "ja<n" using A ja reduce_preserves_dimensions(2) by auto
    show "?reduce_b $$ (i,ja) = (reduce a m D A) $$ (i,ja)"    
    proof (cases "(ia  im)")
      case True
      have "?reduce_b $$ (i,ja) = ?reduce_a $$ (i,ja)" unfolding reduce_b_eq 
        by (smt True dr_eq dc_eq i index_mat(1) ja prod.simps(2) reduce_row_mod_D_preserves_dimensions)
      also have "... = ?A $$ (i,ja)"
        by (smt A True carrier_matD(2) dim_col_mat(1) dim_row_mat(1) i index_mat(1) ja_n 
            reduce_a_eq reduce_preserves_dimensions(1) split_conv)
      also have "... = A $$ (i,ja)" using A True im ja_n by auto
      also have "... = (reduce a m D A) $$ (i,ja)" unfolding reduce_alt_def_not0[OF Aaj pquvd]
        using im ja_n A True by auto
      finally show ?thesis .      
    next
      case False note a_or_b = False
      have gcd_pq: "p * A $$ (a, 0) + q * A $$ (m, 0) = gcd (A $$ (a, 0)) (A $$ (m, 0))"
        by (metis assms(10) euclid_ext2_works(1) euclid_ext2_works(2))
      have gcd_le_D: "gcd (A $$ (a, 0)) (A $$ (m, 0))  D"        
        by (metis Am0_D D0 assms(17) empty_iff gcd_le1_int gcd_le2_int insert_iff)
      show ?thesis
      proof (cases "i=a")
        case True note ia = True
        hence i_not_b: "im" using ab by auto
        have 1: "?reduce_b $$ (i,ja) = ?reduce_a $$ (i,ja)" unfolding reduce_b_eq             
            by (smt ab dc_eq dim_row_mat(1) dr_eq i ia index_mat(1) ja prod.simps(2)
                reduce_b_eq reduce_row_mod_D_preserves_dimensions(2))
        show ?thesis
        proof (cases "ja=0")
          case True note ja0 = True           
          hence ja_notin_xs: "ja  set xs" unfolding xs_def by auto
          have "?reduce_a $$ (i,ja) = p * A $$ (a, 0) + q * A $$ (m, 0)" 
            unfolding reduce_a_eq using True ja0 ab a_or_b i_not_b ja_n im a A False ja_notin_xs
            by auto
          also have "... = (reduce a m D A) $$ (i,ja)"
            unfolding reduce_alt_def_not0[OF Aaj pquvd]
            using True a_or_b i_not_b ja_n im A False               
            using gcd_le_D gcd_pq Am0_D Am0_D2 by auto 
          finally show ?thesis using 1 by auto
        next
          case False
          hence ja_in_xs: "ja  set xs"
            unfolding xs_def using True ja_n im a A unfolding set_filter by auto
          have "?reduce_a $$ (i,ja) = ?A $$ (i, ja) gmod D"
            unfolding reduce_a_eq using True ab a_or_b i_not_b ja_n im a A ja_in_xs False by auto
          also have "... = (reduce a m D A) $$ (i,ja)"
            unfolding reduce_alt_def_not0[OF Aaj pquvd] using True a_or_b i_not_b ja_n im A False by auto
          finally show ?thesis using 1 by simp
        qed
      next
        case False note i_not_a = False
        have i_drb: "i<dim_row ?reduce_b" 
          and i_dra: "i<dim_row ?reduce_a" 
          and ja_drb: "ja < dim_col ?reduce_b"
          and ja_dra: "ja < dim_col ?reduce_a" using i ja reduce_carrier[OF A] A ja_n im by auto
        have ib: "i=m" using False a_or_b by auto
        show ?thesis
        proof (cases "ja = 0")
          case True note ja0 = True
          have uv: "u * A $$ (a, ja) + v * A $$ (m, ja) = 0"
            unfolding euclid_ext2_works[OF pquvd[symmetric]] True
            by (smt euclid_ext2_works[OF pquvd[symmetric]] more_arith_simps(11) mult.commute mult_minus_left)
          have "?reduce_b $$ (i,ja) = u * A $$ (a, ja) + v * A $$ (m, ja)"
            by (smt (z3) A A_carrier True assms(4) carrier_matD i ib index_mat(1) reduce_a_eq
                ja_dra old.prod.case reduce_preserves_dimensions(1) zero_notin_ys reduce_b_eq
                reduce_row_mod_D_preserves_dimensions)
          also have "... = 0" using uv by blast
          also have "... = (reduce a m D A) $$ (i,ja)" 
            unfolding reduce_alt_def_not0[OF Aaj pquvd] using True False a_or_b ib ja_n im A 
              using i_not_a uv by auto
          finally show ?thesis by auto
        next
          case False
          have ja_in_ys: "ja  set ys"
            unfolding ys_def using False ib ja_n im a  A unfolding set_filter by auto
          have "?reduce_b $$ (i,ja) = (if ja = 0 then if D dvd ?reduce_a$$(i,ja) then D
                                  else ?reduce_a $$ (i, ja) else ?reduce_a $$ (i, ja) gmod D)"
            unfolding reduce_b_eq using i_not_a  ja ja_in_ys 
            by (smt i_dra ja_dra a_or_b index_mat(1) prod.simps(2))
          also have "... = (if ja = 0 then if D dvd ?reduce_a$$(i,ja) then D
                            else ?A $$ (i, ja) else ?A $$ (i, ja) gmod D)"
            unfolding reduce_a_eq using ab a_or_b ib False ja_n im a A ja_in_ys by auto
          also have "... = (reduce a m D A) $$ (i,ja)"
            unfolding reduce_alt_def_not0[OF Aaj pquvd] using  False a_or_b ib ja_n im A 
            using i_not_a  by auto         
          finally show ?thesis .
        qed
      qed
    qed
  qed
  have r: "?reduce_a = (P*?BM) * A" using A A'_BZ_A BM P reduce_a_PA by auto
  have "Q * P * ?BM : carrier_mat (m+n) (m+n)" using P BM Q by auto
  moreover have "invertible_mat (Q * P*?BM)"
    using inv_P invertible_bezout BM P invertible_mult_JNF inv_Q Q by (metis mult_carrier_mat)
  moreover have "(reduce a m D A) = (Q * P * ?BM) * A" using reduce_a_eq r reduce_b_eq_reduce
    by (smt BM P Q assoc_mult_mat carrier_matD carrier_mat_triv 
        dim_row_mat(1) index_mult_mat(2,3) reduce_b_Q_reduce)
  ultimately show ?thesis by auto
qed



lemma reduce_abs_invertible_mat_case_m: 
  assumes A': "A'  carrier_mat m n" and B: "B  carrier_mat n n"
    and a: "a<m" and ab: "a  m" 
  and A_def: "A = A' @r B"
    and j: "jset xs. j<n  (B $$ (j, j) = D)  (j'{0..<n}-{j}. B $$ (j, j') = 0)"  
  and Aaj: "A $$ (a,0)  0"
  and mn: "mn"
  and n0: "0<n"
  and pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(m,0))"
  and A2_def: "A2 = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a then (p*A$$(a,k) + q*A$$(m,k))
                   else if i = m then u * A$$(a,k) + v * A$$(m,k)
                   else A$$(i,k)
            )"
  and xs_def: "xs = filter (λi. abs (A2 $$ (a,i)) > D) [0..<n]"
  and ys_def: "ys = filter (λi. abs (A2 $$ (m,i)) > D) [0..<n]"
    and j_ys: "jset ys. j<n  (B $$ (j, j) = D)  (j'{0..<n}-{j}. B $$ (j, j') = 0)"
    and D0: "D > 0"
shows "P. invertible_mat P  P  carrier_mat (m+n) (m+n)  (reduce_abs a m D A) = P * A"
proof -
  let ?A = "Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a then (p*A$$(a,k) + q*A$$(m,k))
                   else if i = m then u * A$$(a,k) + v * A$$(m,k)
                   else A$$(i,k)
            )"
  note xs_def = xs_def[unfolded A2_def]
  note ys_def = ys_def[unfolded A2_def]
  have D: "D m 1m n  carrier_mat n n" using mn by auto
  have A: "A  carrier_mat (m+n) n" using A_def A' B mn by simp
  hence A_carrier: "?A  carrier_mat (m+n) n" by auto

  let ?BM = "bezout_matrix_JNF A a m 0 euclid_ext2"
  
  have A'_BZ_A: "?A = ?BM * A"
    by (rule bezout_matrix_JNF_mult_eq[OF A' _ _ ab A_def B pquvd], insert a, auto)  
  have invertible_bezout: "invertible_mat ?BM"
    by (rule invertible_bezout_matrix_JNF[OF A is_bezout_ext_euclid_ext2 a _ _ Aaj], insert a n0, auto)      
  have BM: "?BM  carrier_mat (m+n) (m+n)" unfolding bezout_matrix_JNF_def using A by auto
  let ?reduce_a = "reduce_row_mod_D_abs ?A a xs D m"
  define A'1 where "A'1 = mat_of_rows n [Matrix.row ?A i. i  [0..<m]]"
  define A'2 where "A'2 = mat_of_rows n [Matrix.row ?A i. i  [m..<dim_row A]]"
  have A_A'_D: "?A = A'1 @r A'2" using append_rows_split A
    by (metis (no_types, lifting) A'1_def A'2_def A_carrier carrier_matD le_add1)
  have j_A'1_A'2: "jset xs. j < n  A'2 $$ (j, j) = D  (j'{0..<n} - {j}. A'2 $$ (j, j') = 0)"
    proof (rule ballI)
      fix ja assume ja: "jaset xs"
      have ja_n: "ja < n" using ja unfolding xs_def by auto
      have ja2: "ja < dim_row A - m" using A mn ja_n by auto
      have ja_m: "ja < m" using ja_n mn by auto
      have abs_A_a_ja_D: "¦(?A $$ (a,ja))¦ > D" using ja unfolding xs_def by auto
      have ja_not_0: "ja  0"
      proof (rule ccontr, simp)
        assume ja_a: "ja = 0" 
        have A_mja_D: "A$$(m,ja) = D"
        proof -
          have "A$$(m,ja) = (A' @r B) $$ (m, ja)" unfolding A_def ..
          also have "... = B $$ (m-m,ja)"                        
            by (metis B append_rows_nth A' assms(9) carrier_matD(1) ja_a less_add_same_cancel1 less_irrefl_nat)
          also have "... = B $$ (0,0)" unfolding ja_a by auto
          also have "... = D" using mn unfolding ja_a using ja_n ja j ja_a by auto 
          finally show ?thesis .
        qed
        have "?A $$ (a, ja) = p*A$$(a,ja) + q*A$$(m,ja)" using A_carrier ja_n a A by auto
        also have "... = d" using pquvd A assms(2) ja_n ja_a
          by (simp add: bezout_coefficients_fst_snd euclid_ext2_def)
        also have "... = gcd (A$$(a,ja)) (A$$(m,ja))"
          by (metis euclid_ext2_works(2) ja_a pquvd)
        also have "abs(...)  D" using A_mja_D  by (simp add: D0)       
        finally have "abs (?A $$ (a, ja))  D" .
        thus False using abs_A_a_ja_D by auto
      qed      
      show "ja < n  A'2 $$ (ja, ja) = D  (j'{0..<n} - {ja}. A'2 $$ (ja, j') = 0)"
      proof -
        have "A'2 $$ (ja, ja) = [Matrix.row ?A i. i  [m..<dim_row A]] ! ja $v ja"
          by (metis (no_types, lifting) A A'2_def add_diff_cancel_left' carrier_matD(1) 
              ja_n length_map length_upt mat_of_rows_index)
        also have "... = ?A $$ (m + ja, ja)" using A mn ja_n by auto
        also have "... = A $$ (m+ja, ja)" using A a mn ja_n ja_not_0 by auto
        also have "... =  (A' @r B) $$ (m + ja, ja)" unfolding A_def ..
        also have "... = B $$ (ja, ja)"
          by (metis B Groups.add_ac(2) append_rows_nth2 assms(1) ja_n mn nat_SN.compat)
        also have "... = D" using j ja by blast
        finally have A2_D: "A'2 $$ (ja, ja) = D" .

        moreover have "(j'{0..<n} - {ja}. A'2 $$ (ja, j') = 0)"
        proof (rule ballI)
          fix j' assume j': "j': {0..<n} - {ja}"
          have "A'2 $$ (ja, j') = [Matrix.row ?A i. i  [m..<dim_row A]] ! ja $v j'"
            unfolding A'2_def by (rule mat_of_rows_index, insert j' ja_n ja2, auto)
          also have "... = ?A $$ (m + ja, j')" using A mn ja_n j' by auto
          also have "... = A $$ (m+ja, j')" using A a mn ja_n ja_not_0 j' by auto
          also have "... =  (A' @r B) $$ (ja + m, j')" unfolding A_def
            by (simp add: add.commute)
          also have "... = B $$ (ja, j')"
            by (rule append_rows_nth2[OF A' B _ ja_m ja_n], insert j', auto)
          also have "... = 0" using mn j' ja_n j ja by auto
          finally show "A'2 $$ (ja, j') = 0" .
        qed
        ultimately show ?thesis using ja_n by simp
      qed
    qed
  have reduce_a_eq: "?reduce_a = Matrix.mat (dim_row ?A) (dim_col ?A) 
    (λ(i, k). if i = a  k  set xs then if k = 0  D dvd ?A $$ (i, k) then D else ?A $$ (i, k) gmod D else ?A $$ (i, k))"
  proof (rule reduce_row_mod_D_abs_case_m'[OF A_A'_D _ _ a j_A'1_A'2 _ mn D0])    
    show "A'2  carrier_mat n n" using A A'2_def by auto
    show "A'1  carrier_mat m n" by (simp add: A'1_def mat_of_rows_def) 
    show "distinct xs" using distinct_filter distinct_upt xs_def by blast
  qed
  have reduce_a: "?reduce_a  carrier_mat (m+n) n" using reduce_a_eq A by auto
  have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P  ?reduce_a = P * ?A"
    by (rule reduce_row_mod_D_abs_invertible_mat_case_m[OF A_A'_D _ _ _ j_A'1_A'2 mn],
        insert a A A'2_def A'1_def, auto)
  from this obtain P where P: "P  carrier_mat (m + n) (m + n)" and inv_P: "invertible_mat P" 
    and reduce_a_PA: "?reduce_a = P * ?A" by blast
  let ?reduce_b = "reduce_row_mod_D_abs ?reduce_a m ys D m"
  let ?B' = "mat_of_rows n [Matrix.row ?reduce_a i. i  [0..<m]]"
  define reduce_a1 where "reduce_a1 = mat_of_rows (dim_col ?reduce_a) [Matrix.row ?reduce_a i. i  [0..<m]]"
  define reduce_a2 where "reduce_a2 = mat_of_rows (dim_col ?reduce_a) [Matrix.row ?reduce_a i. i  [m..<dim_row ?reduce_a]]"
  have reduce_a_split: "?reduce_a = reduce_a1 @r reduce_a2"
    by (unfold reduce_a1_def reduce_a2_def, rule append_rows_split, insert mn A, auto)  
  have zero_notin_ys: "0  set ys"
  proof -
    have m: "m<dim_row A" using A n0 by auto
    have "?A $$ (m,0) =  u * A $$ (a, 0) + v * A $$ (m, 0)" using m n0 a A by auto
    also have "... = 0" using pquvd
      by (smt dvd_mult_div_cancel euclid_ext2_def euclid_ext2_works(3) more_arith_simps(11)
          mult.commute mult_minus_left prod.sel(1) prod.sel(2) semiring_gcd_class.gcd_dvd1)
    finally show ?thesis using D0 unfolding ys_def by auto
  qed
  have reduce_a2: "reduce_a2  carrier_mat n n" unfolding reduce_a2_def using A by auto
  have reduce_a1: "reduce_a1  carrier_mat m n" unfolding reduce_a1_def using A by auto
  have j2: "jset ys. j < n  reduce_a2 $$ (j, j) = D  (j'{0..<n} - {j}. reduce_a2 $$ (j, j') = 0)"
  proof
    fix j assume j_in_ys: "j  set ys"
    have a_jm: "a  j+m" using a by auto
    have m_not_jm: "m  j + m" using zero_notin_ys j_in_ys by fastforce
    have jm: "j+m < dim_row ?A" using A_carrier j_in_ys unfolding ys_def by auto
    have jn: "j < dim_col ?A" using A_carrier j_in_ys unfolding ys_def by auto
    have jm': "j+m < dim_row A" using A_carrier j_in_ys unfolding ys_def by auto
    have jn': "j < dim_col A" using A_carrier j_in_ys unfolding ys_def by auto
    have "reduce_a2 $$ (j, j') = B $$ (j,j')" if j': "j'<n" for j'
    proof -
      have "reduce_a2 $$ (j, j') = ?reduce_a $$ (j+m,j')"
        by (rule append_rows_nth2[symmetric, OF reduce_a1 reduce_a2 reduce_a_split],
            insert j_in_ys mn j', auto simp add: ys_def)
      also have "... = ?A $$ (j+m, j')" using reduce_a_eq jm jn a_jm j' A_carrier by auto          
      also have "... = A $$ (j+m, j')" using a_jm m_not_jm jm' jn' j' A_carrier by auto
      also have "... = B $$ (j,j')"
        by (smt A append_rows_nth2 A' B A_def mn carrier_matD(2) jn' le_Suc_ex that trans_less_add1)
      finally show ?thesis .
    qed
    thus "j < n  reduce_a2 $$ (j, j) = D  (j'{0..<n} - {j}. reduce_a2 $$ (j, j') = 0)"
      using j_ys j_in_ys by auto
  qed
  have reduce_b_eq: "?reduce_b = Matrix.mat (dim_row ?reduce_a) (dim_col ?reduce_a) 
    (λ(i, k). if i = m  k  set ys then if k = 0  D dvd ?reduce_a $$ (i, k) then D else ?reduce_a $$ (i, k) gmod D else ?reduce_a $$ (i, k))"
    by (rule reduce_row_mod_D_abs_case_m''[OF reduce_a_split reduce_a2 reduce_a1 _ j2 _ mn zero_notin_ys],
        insert D0, auto simp add: ys_def)    
  have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P  ?reduce_b = P * ?reduce_a"
    by (rule reduce_row_mod_D_abs_invertible_mat_case_m'[OF reduce_a_split reduce_a2 reduce_a1 _ j2 _ mn zero_notin_ys],
        auto simp add: ys_def) 
  from this obtain Q where Q: "Q  carrier_mat (m + n) (m + n)" and inv_Q: "invertible_mat Q" 
    and reduce_b_Q_reduce: "?reduce_b = Q * ?reduce_a" by blast
  have reduce_b_eq_reduce: "?reduce_b = (reduce_abs a m D A)"
  proof (rule eq_matI)
    show dr_eq: "dim_row ?reduce_b = dim_row (reduce_abs a m D A)" 
      and dc_eq: "dim_col ?reduce_b = dim_col (reduce_abs a m D A)"
      using reduce_preserves_dimensions by auto
    fix i ja assume i: "i<dim_row (reduce_abs a m D A)" and ja: "ja< dim_col (reduce_abs a m D A)"
    have im: "i<m+n" using A i reduce_preserves_dimensions(3) by auto
    have ja_n: "ja<n" using A ja reduce_preserves_dimensions(4) by auto
    show "?reduce_b $$ (i,ja) = (reduce_abs a m D A) $$ (i,ja)"    
    proof (cases "(ia  im)")
      case True
      have "?reduce_b $$ (i,ja) = ?reduce_a $$ (i,ja)" unfolding reduce_b_eq 
        by (smt True dr_eq dc_eq i index_mat(1) ja prod.simps(2) reduce_row_mod_D_preserves_dimensions_abs)
      also have "... = ?A $$ (i,ja)"
        by (smt A True carrier_matD(2) dim_col_mat(1) dim_row_mat(1) i index_mat(1) ja_n 
            reduce_a_eq reduce_preserves_dimensions(3) split_conv)
      also have "... = A $$ (i,ja)" using A True im ja_n by auto
      also have "... = (reduce_abs a m D A) $$ (i,ja)" unfolding reduce_alt_def_not0[OF Aaj pquvd]
        using im ja_n A True by auto
      finally show ?thesis .      
    next
      case False note a_or_b = False
      show ?thesis
      proof (cases "i=a")
        case True note ia = True
        hence i_not_b: "im" using ab by auto
        show ?thesis
        proof (cases "abs((p*A$$(a,ja) + q*A$$(m,ja))) > D")
          case True note ge_D = True
          have ja_in_xs: "ja  set xs"
            unfolding xs_def using True ja_n im a A unfolding set_filter by auto
          have 1: "?reduce_b $$ (i,ja) = ?reduce_a $$ (i,ja)" unfolding reduce_b_eq             
            by (smt ab dc_eq dim_row_mat(1) dr_eq i ia index_mat(1) ja prod.simps(2)
                reduce_b_eq reduce_row_mod_D_preserves_dimensions_abs(2))
          show ?thesis 
          proof (cases "ja = 0  D dvd p*A$$(a,ja) + q*A$$(m,ja)")
            case True
            have "?reduce_a $$ (i,ja) = D"
              unfolding reduce_a_eq using True ab a_or_b i_not_b ja_n im a A ja_in_xs False by auto
            also have "... = (reduce_abs a m D A) $$ (i,ja)"
              unfolding reduce_alt_def_not0[OF Aaj pquvd]
              using True a_or_b i_not_b ja_n im A False ge_D               
              by auto 
            finally show ?thesis using 1 by simp
          next
            case False
            have "?reduce_a $$ (i,ja) = ?A $$ (i, ja) gmod D"
              unfolding reduce_a_eq using True ab a_or_b i_not_b ja_n im a A ja_in_xs False by auto
            also have "... = (reduce_abs a m D A) $$ (i,ja)"
              unfolding reduce_alt_def_not0[OF Aaj pquvd] using True a_or_b i_not_b ja_n im A False by auto
            finally show ?thesis using 1 by simp
          qed        
        next
          case False
          have ja_in_xs: "ja  set xs"
            unfolding xs_def using False ja_n im a A unfolding set_filter by auto
          have "?reduce_b $$ (i,ja) = ?reduce_a $$ (i,ja)" unfolding reduce_b_eq             
            by (smt ab dc_eq dim_row_mat(1) dr_eq i ia index_mat(1) ja prod.simps(2)
                reduce_b_eq reduce_row_mod_D_preserves_dimensions_abs(2))
          also have "... = ?A $$ (i, ja)"
            unfolding reduce_a_eq using False ab a_or_b i_not_b ja_n im a A ja_in_xs by auto
          also have "... = (reduce_abs a m D A) $$ (i,ja)"
            unfolding reduce_alt_def_not0[OF Aaj pquvd] using False a_or_b i_not_b ja_n im A by auto
          finally show ?thesis .
        qed
      next
        case False note i_not_a = False
        have i_drb: "i<dim_row ?reduce_b" 
          and i_dra: "i<dim_row ?reduce_a" 
          and ja_drb: "ja < dim_col ?reduce_b"
          and ja_dra: "ja < dim_col ?reduce_a" using i ja reduce_carrier[OF A] A ja_n im by auto
          have ib: "i=m" using False a_or_b by auto
        show ?thesis
        proof (cases "abs((u*A$$(a,ja) + v * A$$(m,ja))) > D")
          case True note ge_D = True
          have ja_in_ys: "ja  set ys"
            unfolding ys_def using True False ib ja_n im a  A unfolding set_filter by auto
          have "?reduce_b $$ (i,ja) = (if ja = 0  D dvd ?reduce_a$$(i,ja) then D else ?reduce_a $$ (i, ja) gmod D)"
            unfolding reduce_b_eq using i_not_a True  ja ja_in_ys 
            by (smt i_dra ja_dra a_or_b index_mat(1) prod.simps(2))
          also have "... = (if ja = 0  D dvd ?reduce_a$$(i,ja) then D else ?A $$ (i, ja) gmod D)"
            unfolding reduce_a_eq using True ab a_or_b ib False ja_n im a A ja_in_ys by auto
          also have "... = (reduce_abs a m D A) $$ (i,ja)"
          proof (cases "ja = 0  D dvd ?reduce_a$$(i,ja)")
            case True
            have ja0: "ja=0" using True by auto
            have "u * A $$ (a, ja) + v * A $$ (m, ja) = 0"
              unfolding euclid_ext2_works[OF pquvd[symmetric]] ja0
              by (smt euclid_ext2_works[OF pquvd[symmetric]] more_arith_simps(11) mult.commute mult_minus_left)
            hence abs_0: "abs((u*A$$(a,ja) + v * A$$(m,ja))) = 0" by auto
            show ?thesis using abs_0 D0 ge_D by linarith           
          next
            case False
            then show ?thesis 
              unfolding reduce_alt_def_not0[OF Aaj pquvd] using True ge_D False a_or_b ib ja_n im A 
              using i_not_a by auto           
          qed      
          finally show ?thesis .
        next
          case False
          have ja_in_ys: "ja  set ys"
            unfolding ys_def using i_not_a False ib ja_n im a  A unfolding set_filter by auto
          have "?reduce_b $$ (i,ja) = ?reduce_a $$ (i,ja)" unfolding reduce_b_eq             
            by (smt False a_or_b dc_eq dim_row_mat(1) dr_eq i index_mat(1) ja ja_in_ys
                prod.simps(2) reduce_b_eq reduce_row_mod_D_preserves_dimensions_abs(2))
          also have "... = ?A $$ (i, ja)"
            unfolding reduce_a_eq using False ab a_or_b i_not_a ja_n im a A ja_in_ys by auto
          also have "... = (reduce_abs a m D A) $$ (i,ja)"
            unfolding reduce_alt_def_not0[OF Aaj pquvd] using False a_or_b i_not_a ja_n im A by auto
          finally show ?thesis .
        qed
      qed      
    qed    
  qed
  have r: "?reduce_a = (P*?BM) * A" using A A'_BZ_A BM P reduce_a_PA by auto
  have "Q * P * ?BM : carrier_mat (m+n) (m+n)" using P BM Q by auto
  moreover have "invertible_mat (Q * P*?BM)"
    using inv_P invertible_bezout BM P invertible_mult_JNF inv_Q Q by (metis mult_carrier_mat)
  moreover have "(reduce_abs a m D A) = (Q * P * ?BM) * A" using reduce_a_eq r reduce_b_eq_reduce
    by (smt BM P Q assoc_mult_mat carrier_matD carrier_mat_triv 
        dim_row_mat(1) index_mult_mat(2,3) reduce_b_Q_reduce)
  ultimately show ?thesis by auto
qed




lemma reduce_not0:
  assumes A: "A  carrier_mat m n" and a: "a<m" and a_less_b: "a<b" and j: "0<n" and b: "b<m"
    and Aaj: "A $$ (a,0)  0" and D0: "D  0"
  shows "reduce a b D A $$ (a, 0)  0" (is "?reduce $$ (a,0)  _")
  and "reduce_abs a b D A $$ (a, 0)  0" (is "?reduce_abs $$ (a,0)  _")
proof -
  have "?reduce $$ (a,0) = (let r = gcd (A $$ (a, 0)) (A $$ (b, 0)) in if D dvd r then D else r)" 
    by (rule reduce_gcd[OF A _ j Aaj], insert a, simp)
  also have "...  0" unfolding Let_def using D0 
    by (smt Aaj gcd_eq_0_iff gmod_0_imp_dvd)
  finally show "reduce a b D A $$ (a, 0)  0" .
  have "?reduce_abs $$ (a,0) = (let r = gcd (A $$ (a, 0)) (A $$ (b, 0)) in 
        if D < r then if D dvd r then D else r gmod D else r)"
    by (rule reduce_gcd[OF A _ j Aaj], insert a, simp)
  also have "...  0" unfolding Let_def using D0 
    by (smt Aaj gcd_eq_0_iff gmod_0_imp_dvd)
  finally show "reduce_abs a b D A $$ (a, 0)  0" .
qed

lemma reduce_below_not0:
 assumes A: "A  carrier_mat m n" and a: "a<m" and j: "0<n" 
    and Aaj: "A $$ (a,0)  0" 
and "distinct xs" and "x  set xs. x < m  a < x"
  and "D 0"
  shows "reduce_below a xs D A $$ (a, 0)  0" (is "?R $$ (a,0)  _")
  using assms
proof (induct a xs D A arbitrary: A rule: reduce_below.induct)
  case (1 a D A)
  then show ?case by auto
next
  case (2 a x xs D A)
  note A = "2.prems"(1)
  note a = "2.prems"(2)
  note j = "2.prems"(3)
  note Aaj = "2.prems"(4)
  note d = "2.prems"(5)
  note D0 = "2.prems"(7)
  note x_less_xxs = "2.prems"(6)
  have xm: "x < m" using "2.prems" by auto
  have D1: "D m 1m n  carrier_mat n n" by simp
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "reduce a x D A"
  have reduce_ax: "?reduce_ax  carrier_mat m n"
    by (metis (no_types, lifting) A carrier_matD carrier_mat_triv reduce_preserves_dimensions)
  have h: "reduce_below a xs D (reduce a x D A) $$ (a,0)  0"
  proof (rule "2.hyps")
    show "reduce a x D A $$ (a, 0)  0"
      by (rule reduce_not0[OF A a _ j xm Aaj D0], insert x_less_xxs, simp)
  qed (insert A a j Aaj d x_less_xxs xm reduce_ax D0, auto)
  thus ?case by auto
qed



lemma reduce_below_abs_not0:
 assumes A: "A  carrier_mat m n" and a: "a<m" and j: "0<n" 
    and Aaj: "A $$ (a,0)  0" 
and "distinct xs" and "x  set xs. x < m  a < x"
  and "D 0"
  shows "reduce_below_abs a xs D A $$ (a, 0)  0" (is "?R $$ (a,0)  _")
  using assms
proof (induct a xs D A arbitrary: A rule: reduce_below_abs.induct)
  case (1 a D A)
  then show ?case by auto
next
  case (2 a x xs D A)
  note A = "2.prems"(1)
  note a = "2.prems"(2)
  note j = "2.prems"(3)
  note Aaj = "2.prems"(4)
  note d = "2.prems"(5)
  note D0 = "2.prems"(7)
  note x_less_xxs = "2.prems"(6)
  have xm: "x < m" using "2.prems" by auto
  have D1: "D m 1m n  carrier_mat n n" by simp
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "reduce_abs a x D A"
  have reduce_ax: "?reduce_ax  carrier_mat m n"
    by (metis (no_types, lifting) A carrier_matD carrier_mat_triv reduce_preserves_dimensions)
  have h: "reduce_below_abs a xs D (reduce_abs a x D A) $$ (a,0)  0"
  proof (rule "2.hyps")
    show "reduce_abs a x D A $$ (a, 0)  0"
      by (rule reduce_not0[OF A a _ j xm Aaj D0], insert x_less_xxs, simp)
  qed (insert A a j Aaj d x_less_xxs xm reduce_ax D0, auto)
  thus ?case by auto
qed



lemma reduce_below_not0_case_m:
 assumes A': "A'  carrier_mat m n" and a: "a<m" and j: "0<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (a,0)  0"
    and mn: "mn"
    and "x  set xs. x < m  a < x"
    and "D  0"
  shows "reduce_below a (xs@[m]) D A $$ (a, 0)  0" (is "?R $$ (a,0)  _")
  using assms
proof (induct a xs D A arbitrary: A A' rule: reduce_below.induct)
  case (1 a D A)
  note A' = "1.prems"(1)
  note a = "1.prems"(2)
  note n = "1.prems"(3)
  note A_def = "1.prems"(4)
  note Aaj = "1.prems"(5)
  note mn = "1.prems"(6)
  note all_less_xxs = "1.prems"(7)
  note D0 = "1.prems"(8)
  have A: "A  carrier_mat (m+n) n" using A' A_def by auto
  have "reduce_below a ([] @ [m]) D A $$ (a, 0) = reduce_below a [m] D A $$ (a, 0)" by auto
  also have "... = reduce a m D A $$ (a, 0)" by auto
  also have "...  0"
    by (rule reduce_not0[OF A _ a n _ Aaj D0], insert a n, auto)
  finally show ?case .
next
  case (2 a x xs D A)
  note A' = "2.prems"(1)
  note a = "2.prems"(2)
  note n = "2.prems"(3)
  note A_def = "2.prems"(4)
  note Aaj = "2.prems"(5)
  note mn = "2.prems"(6)
  note x_less_xxs = "2.prems"(7)
  note D0= "2.prems"(8)
  have xm: "x < m" using "2.prems" by auto
  have D1: "D m 1m n  carrier_mat n n" by simp
  have A: "A  carrier_mat (m+n) n" using A' A_def by auto
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "reduce a x D A"
  have reduce_ax: "?reduce_ax  carrier_mat (m+n) n"
    by (metis (no_types, lifting) A carrier_matD carrier_mat_triv reduce_preserves_dimensions)
  have h: "reduce_below a (xs@[m]) D (reduce a x D A) $$ (a,0)  0"
  proof (rule "2.hyps")
    show "reduce a x D A $$ (a, 0)  0"
      by (rule reduce_not0[OF A _ _ _ _ _ D0], insert x_less_xxs j Aaj, auto)
    let ?reduce_ax' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
    show "?reduce_ax = ?reduce_ax' @r D m 1m n" by (rule reduce_append_rows_eq[OF A' A_def a xm n Aaj])
  qed (insert A a j Aaj x_less_xxs xm reduce_ax mn D0, auto)
  thus ?case by auto
qed

lemma reduce_below_abs_not0_case_m:
 assumes A': "A'  carrier_mat m n" and a: "a<m" and j: "0<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (a,0)  0"
    and mn: "mn"
    and "x  set xs. x < m  a < x"
    and "D  0"
  shows "reduce_below_abs a (xs@[m]) D A $$ (a, 0)  0" (is "?R $$ (a,0)  _")
  using assms
proof (induct a xs D A arbitrary: A A' rule: reduce_below_abs.induct)
  case (1 a D A)
  note A' = "1.prems"(1)
  note a = "1.prems"(2)
  note n = "1.prems"(3)
  note A_def = "1.prems"(4)
  note Aaj = "1.prems"(5)
  note mn = "1.prems"(6)
  note all_less_xxs = "1.prems"(7)
  note D0 = "1.prems"(8)
  have A: "A  carrier_mat (m+n) n" using A' A_def by auto
  have "reduce_below_abs a ([] @ [m]) D A $$ (a, 0) = reduce_below_abs a [m] D A $$ (a, 0)" by auto
  also have "... = reduce_abs a m D A $$ (a, 0)" by auto
  also have "...  0"
    by (rule reduce_not0[OF A _ a n _ Aaj D0], insert a n, auto)
  finally show ?case .
next
  case (2 a x xs D A)
  note A' = "2.prems"(1)
  note a = "2.prems"(2)
  note n = "2.prems"(3)
  note A_def = "2.prems"(4)
  note Aaj = "2.prems"(5)
  note mn = "2.prems"(6)
  note x_less_xxs = "2.prems"(7)
  note D0= "2.prems"(8)
  have xm: "x < m" using "2.prems" by auto
  have D1: "D m 1m n  carrier_mat n n" by simp
  have A: "A  carrier_mat (m+n) n" using A' A_def by auto
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "reduce_abs a x D A"
  have reduce_ax: "?reduce_ax  carrier_mat (m+n) n"
    by (metis (no_types, lifting) A carrier_matD carrier_mat_triv reduce_preserves_dimensions)
  have h: "reduce_below_abs a (xs@[m]) D (reduce_abs a x D A) $$ (a,0)  0"
  proof (rule "2.hyps")
    show "reduce_abs a x D A $$ (a, 0)  0"
      by (rule reduce_not0[OF A _ _ _ _ _ D0], insert x_less_xxs j Aaj, auto)
    let ?reduce_ax' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
    show "?reduce_ax = ?reduce_ax' @r D m 1m n" by (rule reduce_append_rows_eq[OF A' A_def a xm n Aaj])
  qed (insert A a j Aaj x_less_xxs xm reduce_ax mn D0, auto)
  thus ?case by auto
qed





lemma reduce_below_invertible_mat:
  assumes A': "A'  carrier_mat m n" and a: "a<m" and j: "0<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (a,0)  0"
    and "distinct xs" and "x  set xs. x < m  a < x"
    and "mn"
    and "D>0"
  shows "(P. invertible_mat P  P  carrier_mat (m+n) (m+n)  reduce_below a xs D A = P * A)"
  using assms
proof (induct a xs D A arbitrary: A' rule: reduce_below.induct)
  case (1 a D A)
  then show ?case
    by (metis append_rows_def carrier_matD(1) index_mat_four_block(2) reduce_below.simps(1)
        index_smult_mat(2) index_zero_mat(2) invertible_mat_one left_mult_one_mat' one_carrier_mat)
next
  case (2 a x xs D A)
  note A' = "2.prems"(1)
  note a = "2.prems"(2)
  note j = "2.prems"(3)
  note A_def = "2.prems"(4)
  note Aaj = "2.prems"(5)
  note d = "2.prems"(6)
  note x_less_xxs = "2.prems"(7)
  note mn = "2.prems"(8)
  note D_ge0 = "2.prems"(9)
  have D0: "D0" using D_ge0 by simp
  have A: "A  carrier_mat (m+n) n" using A' A_def by auto
  have xm: "x < m" using "2.prems" by auto
  have D1: "D m 1m n  carrier_mat n n" by simp
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "reduce a x D A"
  have reduce_ax: "?reduce_ax  carrier_mat (m + n) n"
    by (metis (no_types, lifting) "2" add.comm_neutral append_rows_def 
        carrier_matD carrier_mat_triv index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3) reduce_preserves_dimensions)
  have h: "(P. invertible_mat P  P  carrier_mat (m + n) (m + n) 
     reduce_below a xs D (reduce a x D A) = P * reduce a x D A)"
  proof (rule "2.hyps"[OF _ a j _ _ ])
    let ?A' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
    show "reduce a x D A = ?A' @r D m 1m n"
      by (rule reduce_append_rows_eq[OF A' A_def a xm j Aaj])  
    show "reduce a x D A $$ (a, 0)  0"
      by (rule reduce_not0[OF A _ _ j _ Aaj], insert "2.prems", auto)
  qed (insert mn d x_less_xxs D_ge0, auto)
  from this obtain P where inv_P: "invertible_mat P" and P: "P  carrier_mat (m + n) (m + n)"
    and rb_Pr: "reduce_below a xs D (reduce a x D A) = P * reduce a x D A" by blast
  have *: "reduce_below a (x # xs) D A = reduce_below a xs D (reduce a x D A)" by simp
  have "Q. invertible_mat Q  Q  carrier_mat (m+n) (m+n)  (reduce a x D A) = Q * A"
    by (rule reduce_invertible_mat[OF A' a j xm _ A_def Aaj ], insert "2.prems", auto)
  from this obtain Q where inv_Q: "invertible_mat Q" and Q: "Q  carrier_mat (m + n) (m + n)"
    and r_QA: "reduce a x D A = Q * A" by blast
  have "invertible_mat (P*Q)" using inv_P inv_Q P Q invertible_mult_JNF by blast
  moreover have "P * Q  carrier_mat (m+n) (m+n)" using P Q by auto
  moreover have "reduce_below a (x # xs) D A = (P*Q) * A" 
    by (smt P Q * assoc_mult_mat carrier_matD(1) carrier_mat_triv index_mult_mat(2) 
        r_QA rb_Pr reduce_preserves_dimensions(1))
  ultimately show ?case by blast
qed


lemma reduce_below_abs_invertible_mat:
  assumes A': "A'  carrier_mat m n" and a: "a<m" and j: "0<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (a,0)  0"
    and "distinct xs" and "x  set xs. x < m  a < x"
    and "mn"
    and "D>0"
  shows "(P. invertible_mat P  P  carrier_mat (m+n) (m+n)  reduce_below_abs a xs D A = P * A)"
  using assms
proof (induct a xs D A arbitrary: A' rule: reduce_below_abs.induct)
  case (1 a D A)
  then show ?case
    by (metis carrier_append_rows invertible_mat_one left_mult_one_mat one_carrier_mat
        reduce_below_abs.simps(1) smult_carrier_mat)
next
  case (2 a x xs D A)
  note A' = "2.prems"(1)
  note a = "2.prems"(2)
  note j = "2.prems"(3)
  note A_def = "2.prems"(4)
  note Aaj = "2.prems"(5)
  note d = "2.prems"(6)
  note x_less_xxs = "2.prems"(7)
  note mn = "2.prems"(8)
  note D_ge0 = "2.prems"(9)
  have D0: "D0" using D_ge0 by simp
  have A: "A  carrier_mat (m+n) n" using A' A_def by auto
  have xm: "x < m" using "2.prems" by auto
  have D1: "D m 1m n  carrier_mat n n" by simp
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "reduce_abs a x D A"
  have reduce_ax: "?reduce_ax  carrier_mat (m + n) n"
    by (metis (no_types, lifting) "2" add.comm_neutral append_rows_def 
        carrier_matD carrier_mat_triv index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3) reduce_preserves_dimensions)
  have h: "(P. invertible_mat P  P  carrier_mat (m + n) (m + n) 
     reduce_below_abs a xs D (reduce_abs a x D A) = P * reduce_abs a x D A)"
  proof (rule "2.hyps"[OF _ a j _ _ ])
    let ?A' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
    show "reduce_abs a x D A = ?A' @r D m 1m n"
      by (rule reduce_append_rows_eq[OF A' A_def a xm j Aaj])  
    show "reduce_abs a x D A $$ (a, 0)  0"
      by (rule reduce_not0[OF A _ _ j _ Aaj], insert "2.prems", auto)
  qed (insert mn d x_less_xxs D_ge0, auto)
  from this obtain P where inv_P: "invertible_mat P" and P: "P  carrier_mat (m + n) (m + n)"
    and rb_Pr: "reduce_below_abs a xs D (reduce_abs a x D A) = P * reduce_abs a x D A" by blast
  have *: "reduce_below_abs a (x # xs) D A = reduce_below_abs a xs D (reduce_abs a x D A)" by simp
  have "Q. invertible_mat Q  Q  carrier_mat (m+n) (m+n)  (reduce_abs a x D A) = Q * A"
    by (rule reduce_abs_invertible_mat[OF A' a j xm _ A_def Aaj ], insert "2.prems", auto)
  from this obtain Q where inv_Q: "invertible_mat Q" and Q: "Q  carrier_mat (m + n) (m + n)"
    and r_QA: "reduce_abs a x D A = Q * A" by blast
  have "invertible_mat (P*Q)" using inv_P inv_Q P Q invertible_mult_JNF by blast
  moreover have "P * Q  carrier_mat (m+n) (m+n)" using P Q by auto
  moreover have "reduce_below_abs a (x # xs) D A = (P*Q) * A" 
    by (smt P Q * assoc_mult_mat carrier_matD(1) carrier_mat_triv index_mult_mat(2) 
        r_QA rb_Pr reduce_preserves_dimensions(3))
  ultimately show ?case by blast
qed



lemma reduce_below_preserves:
  assumes A': "A'  carrier_mat m n" and a: "a<m" and j: "j<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (a,0)  0"
    and mn: "mn"
  assumes "i  set xs" and "distinct xs" and "x  set xs. x < m  a < x"
    and "ia" and "i<m+n"
  and "D>0"
  shows "reduce_below a xs D A $$ (i,j) = A $$ (i,j)"
  using assms
proof (induct a xs D A arbitrary: A' i rule: reduce_below.induct)
  case (1 a D A)
  then show ?case by auto
next
  case (2 a x xs D A)
  note A' = "2.prems"(1)
  note a = "2.prems"(2)
  note j = "2.prems"(3)
  note A_def = "2.prems"(4)
  note Aaj = "2.prems"(5)
  note mn = "2.prems"(6)
  note i_set_xxs = "2.prems"(7)
  note d = "2.prems"(8)
  note xxs_less_m = "2.prems"(9)
  note ia = "2.prems"(10)
  note imm = "2.prems"(11)
  note D_ge0 = "2.prems"(12)
  have D0: "D0" using D_ge0 by simp
  have A: "A  carrier_mat (m+n) n" using A' mn A_def by auto
  have xm: "x < m"  using "2.prems" by auto
  have D1: "D m 1m n  carrier_mat n n" by (simp add: mn)
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "(reduce a x D A)"
  have reduce_ax: "?reduce_ax  carrier_mat (m + n) n"
    by (metis (no_types, lifting) 2 add.comm_neutral append_rows_def 
        carrier_matD carrier_mat_triv index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3) reduce_preserves_dimensions)
  have "reduce_below a (x # xs) D A $$ (i, j) = reduce_below a xs D (reduce a x D A) $$ (i, j)"
    by auto
  also have "... = reduce a x D A $$ (i, j)"
  proof (rule "2.hyps"[OF _ a j _ _ mn _ _ _ ia imm D_ge0])
    let ?A' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
    show "reduce a x D A = ?A' @r D m 1m n"
      by (rule reduce_append_rows_eq[OF A' A_def a xm _ Aaj], insert j, auto)  
    show "i  set xs" using i_set_xxs by auto
    show "distinct xs" using d by auto
    show "xset xs. x < m  a < x" using xxs_less_m by auto
    show "reduce a x D A $$ (a, 0)  0"
      by (rule reduce_not0[OF A _ _ _ _ Aaj], insert "2.prems", auto)
    show "?A'  carrier_mat m n" by auto    
  qed  
  also have "... = A $$ (i,j)" by (rule reduce_preserves[OF A j Aaj], insert "2.prems", auto)
  finally show ?case .
qed




lemma reduce_below_abs_preserves:
  assumes A': "A'  carrier_mat m n" and a: "a<m" and j: "j<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (a,0)  0"
    and mn: "mn"
  assumes "i  set xs" and "distinct xs" and "x  set xs. x < m  a < x"
    and "ia" and "i<m+n"
  and "D>0"
  shows "reduce_below_abs a xs D A $$ (i,j) = A $$ (i,j)"
  using assms
proof (induct a xs D A arbitrary: A' i rule: reduce_below_abs.induct)
  case (1 a D A)
  then show ?case by auto
next
  case (2 a x xs D A)
  note A' = "2.prems"(1)
  note a = "2.prems"(2)
  note j = "2.prems"(3)
  note A_def = "2.prems"(4)
  note Aaj = "2.prems"(5)
  note mn = "2.prems"(6)
  note i_set_xxs = "2.prems"(7)
  note d = "2.prems"(8)
  note xxs_less_m = "2.prems"(9)
  note ia = "2.prems"(10)
  note imm = "2.prems"(11)
  note D_ge0 = "2.prems"(12)
  have D0: "D0" using D_ge0 by simp
  have A: "A  carrier_mat (m+n) n" using A' mn A_def by auto
  have xm: "x < m"  using "2.prems" by auto
  have D1: "D m 1m n  carrier_mat n n" by (simp add: mn)
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "(reduce_abs a x D A)"
  have reduce_ax: "?reduce_ax  carrier_mat (m + n) n"
    by (metis (no_types, lifting) 2 add.comm_neutral append_rows_def 
        carrier_matD carrier_mat_triv index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3) reduce_preserves_dimensions)
  have "reduce_below_abs a (x # xs) D A $$ (i, j) = reduce_below_abs a xs D (reduce_abs a x D A) $$ (i, j)"
    by auto
  also have "... = reduce_abs a x D A $$ (i, j)"
  proof (rule "2.hyps"[OF _ a j _ _ mn _ _ _ ia imm D_ge0])
    let ?A' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
    show "reduce_abs a x D A = ?A' @r D m 1m n"
      by (rule reduce_append_rows_eq[OF A' A_def a xm _ Aaj], insert j, auto)  
    show "i  set xs" using i_set_xxs by auto
    show "distinct xs" using d by auto
    show "xset xs. x < m  a < x" using xxs_less_m by auto
    show "reduce_abs a x D A $$ (a, 0)  0"
      by (rule reduce_not0[OF A _ _ _ _ Aaj], insert "2.prems", auto)
    show "?A'  carrier_mat m n" by auto    
  qed  
  also have "... = A $$ (i,j)" by (rule reduce_preserves[OF A j Aaj], insert "2.prems", auto)
  finally show ?case .
qed



lemma reduce_below_0:
  assumes A': "A'  carrier_mat m n" and a: "a<m" and j: "0<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (a,0)  0"
    and mn: "mn"
  assumes "i  set xs" and "distinct xs" and "x  set xs. x < m  a < x"
  and "D>0"
  shows "reduce_below a xs D A $$ (i,0) = 0"
  using assms
proof (induct a xs D A arbitrary: A' i rule: reduce_below.induct)
  case (1 a D A)
  then show ?case by auto
next
  case (2 a x xs D A)
  note A' = "2.prems"(1)
  note a = "2.prems"(2)
  note j = "2.prems"(3)
  note A_def = "2.prems"(4)
  note Aaj = "2.prems"(5)
  note mn = "2.prems"(6)
  note i_set_xxs = "2.prems"(7)
  note d = "2.prems"(8)
  note xxs_less_m = "2.prems"(9)
  note D_ge0 = "2.prems"(10)
  have D0: "D0" using D_ge0 by simp
  have A: "A  carrier_mat (m+n) n" using A' mn A_def by auto
  have xm: "x < m"  using "2.prems" by auto
  have D1: "D m 1m n  carrier_mat n n" by (simp add: mn)
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "reduce a x D A"
  have reduce_ax: "?reduce_ax  carrier_mat (m + n) n"
    by (metis (no_types, lifting) "2" add.comm_neutral append_rows_def 
        carrier_matD carrier_mat_triv index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3) reduce_preserves_dimensions)
  show ?case
  proof (cases "i=x")
    case True
    have "reduce_below a (x # xs) D A $$ (i, 0) = reduce_below a xs D (reduce a x D A) $$ (i, 0)"
      by auto
    also have "... = (reduce a x D A) $$ (i, 0)"
    proof (rule reduce_below_preserves[OF _ a j _ _ mn ])
      let ?A' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
      show "reduce a x D A = ?A' @r D m 1m n"
        by (rule reduce_append_rows_eq[OF A' A_def a xm j Aaj])      
      show "distinct xs" using d by auto
      show "xset xs. x < m  a < x" using xxs_less_m by auto
      show "reduce a x D A $$ (a, 0)  0"
        by (rule reduce_not0[OF A _ _ j _ Aaj], insert "2.prems", auto)
      show "?A'  carrier_mat m n" by auto
      show "i  set xs" using True d by auto
      show "i  a" using "2.prems" by blast
      show "i < m + n"
        by (simp add: True trans_less_add1 xm)
    qed (insert D_ge0)
    also have "... = 0" unfolding True by (rule reduce_0[OF A _ j _ _ Aaj], insert "2.prems", auto)
    finally show ?thesis .
  next
    case False note i_not_x = False    
    have h: "reduce_below a xs D (reduce a x D A) $$ (i, 0) = 0 "
    proof (rule "2.hyps"[OF _ a j _ _ mn])
      let ?A' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
      show "reduce a x D A = ?A' @r D m 1m n"
      proof (rule matrix_append_rows_eq_if_preserves[OF reduce_ax D1])
        show "i{m..<m + n}. ja<n. ?reduce_ax $$ (i, ja) = (D m 1m n) $$ (i - m, ja)" 
        proof (rule+)
          fix i ja assume i: "i  {m..<m + n}" and ja: "ja < n"
          have ja_dc: "ja < dim_col A" and i_dr: "i < dim_row A" using i ja A by auto
          have i_not_a: "i  a" using i a by auto
          have i_not_x: "i  x" using i xm by auto
          have "?reduce_ax $$ (i,ja) = A $$ (i,ja)" 
            unfolding reduce_alt_def_not0[OF Aaj pquvd] using ja_dc i_dr i_not_a i_not_x by auto 
          also have "... = (if i < dim_row A' then A' $$(i,ja) else (D m (1m n))$$(i-m,ja))"
            by (unfold A_def, rule append_rows_nth[OF A' D1 _ ja], insert A i_dr, simp)
          also have "... = (D m 1m n) $$ (i - m, ja)" using i A' by auto
          finally show "?reduce_ax $$ (i,ja) = (D m 1m n) $$ (i - m, ja)" .   
        qed
      qed
      show "i  set xs" using i_set_xxs i_not_x by auto
      show "distinct xs" using d by auto
      show "xset xs. x < m  a < x" using xxs_less_m by auto
      show "reduce a x D A $$ (a, 0)  0"
        by (rule reduce_not0[OF A _ _ j _ Aaj], insert "2.prems", auto)
      show "?A'  carrier_mat m n" by auto
    qed (insert D_ge0)
    have "reduce_below a (x # xs) D A $$ (i, 0) = reduce_below a xs D (reduce a x D A) $$ (i, 0)"
      by auto
    also have "... = 0" using h .
    finally show ?thesis .
  qed
qed

lemma reduce_below_abs_0:
  assumes A': "A'  carrier_mat m n" and a: "a<m" and j: "0<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (a,0)  0"
    and mn: "mn"
  assumes "i  set xs" and "distinct xs" and "x  set xs. x < m  a < x"
  and "D>0"
  shows "reduce_below_abs a xs D A $$ (i,0) = 0"
  using assms
proof (induct a xs D A arbitrary: A' i rule: reduce_below_abs.induct)
  case (1 a D A)
  then show ?case by auto
next
  case (2 a x xs D A)
  note A' = "2.prems"(1)
  note a = "2.prems"(2)
  note j = "2.prems"(3)
  note A_def = "2.prems"(4)
  note Aaj = "2.prems"(5)
  note mn = "2.prems"(6)
  note i_set_xxs = "2.prems"(7)
  note d = "2.prems"(8)
  note xxs_less_m = "2.prems"(9)
  note D_ge0 = "2.prems"(10)
  have D0: "D0" using D_ge0 by simp
  have A: "A  carrier_mat (m+n) n" using A' mn A_def by auto
  have xm: "x < m"  using "2.prems" by auto
  have D1: "D m 1m n  carrier_mat n n" by (simp add: mn)
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "reduce_abs a x D A"
  have reduce_ax: "?reduce_ax  carrier_mat (m + n) n"
    by (metis (no_types, lifting) "2" add.comm_neutral append_rows_def 
        carrier_matD carrier_mat_triv index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3) reduce_preserves_dimensions)
  show ?case
  proof (cases "i=x")
    case True
    have "reduce_below_abs a (x # xs) D A $$ (i, 0) = reduce_below_abs a xs D (reduce_abs a x D A) $$ (i, 0)"
      by auto
    also have "... = (reduce_abs a x D A) $$ (i, 0)"
    proof (rule reduce_below_abs_preserves[OF _ a j _ _ mn ])
      let ?A' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
      show "reduce_abs a x D A = ?A' @r D m 1m n"
        by (rule reduce_append_rows_eq[OF A' A_def a xm j Aaj])      
      show "distinct xs" using d by auto
      show "xset xs. x < m  a < x" using xxs_less_m by auto
      show "reduce_abs a x D A $$ (a, 0)  0"
        by (rule reduce_not0[OF A _ _ j _ Aaj], insert "2.prems", auto)
      show "?A'  carrier_mat m n" by auto
      show "i  set xs" using True d by auto
      show "i  a" using "2.prems" by blast
      show "i < m + n"
        by (simp add: True trans_less_add1 xm)
    qed (insert D_ge0)
    also have "... = 0" unfolding True by (rule reduce_0[OF A _ j _ _ Aaj], insert "2.prems", auto)
    finally show ?thesis .
  next
    case False note i_not_x = False    
    have h: "reduce_below_abs a xs D (reduce_abs a x D A) $$ (i, 0) = 0 "
    proof (rule "2.hyps"[OF _ a j _ _ mn])
      let ?A' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
      show "reduce_abs a x D A = ?A' @r D m 1m n"
      proof (rule matrix_append_rows_eq_if_preserves[OF reduce_ax D1])
        show "i{m..<m + n}. ja<n. ?reduce_ax $$ (i, ja) = (D m 1m n) $$ (i - m, ja)" 
        proof (rule+)
          fix i ja assume i: "i  {m..<m + n}" and ja: "ja < n"
          have ja_dc: "ja < dim_col A" and i_dr: "i < dim_row A" using i ja A by auto
          have i_not_a: "i  a" using i a by auto
          have i_not_x: "i  x" using i xm by auto
          have "?reduce_ax $$ (i,ja) = A $$ (i,ja)" 
            unfolding reduce_alt_def_not0[OF Aaj pquvd] using ja_dc i_dr i_not_a i_not_x by auto 
          also have "... = (if i < dim_row A' then A' $$(i,ja) else (D m (1m n))$$(i-m,ja))"
            by (unfold A_def, rule append_rows_nth[OF A' D1 _ ja], insert A i_dr, simp)
          also have "... = (D m 1m n) $$ (i - m, ja)" using i A' by auto
          finally show "?reduce_ax $$ (i,ja) = (D m 1m n) $$ (i - m, ja)" .   
        qed
      qed
      show "i  set xs" using i_set_xxs i_not_x by auto
      show "distinct xs" using d by auto
      show "xset xs. x < m  a < x" using xxs_less_m by auto
      show "reduce_abs a x D A $$ (a, 0)  0"
        by (rule reduce_not0[OF A _ _ j _ Aaj], insert "2.prems", auto)
      show "?A'  carrier_mat m n" by auto
    qed (insert D_ge0)
    have "reduce_below_abs a (x # xs) D A $$ (i, 0) = reduce_below_abs a xs D (reduce_abs a x D A) $$ (i, 0)"
      by auto
    also have "... = 0" using h .
    finally show ?thesis .
  qed
qed




lemma reduce_below_preserves_case_m:
  assumes A': "A'  carrier_mat m n" and a: "a<m" and j: "j<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (a,0)  0"
    and mn: "mn"
  assumes "i  set xs" and "distinct xs" and "x  set xs. x < m  a < x"
    and "ia" and "i<m+n" and "i m"
  and "D>0"
  shows "reduce_below a (xs @ [m]) D A $$ (i,j) = A $$ (i,j)"
  using assms
proof (induct a xs D A arbitrary: A' i rule: reduce_below.induct)
  case (1 a D A)
  have "reduce_below a ([] @ [m]) D A $$ (i, j) =  reduce_below a [m] D A $$ (i, j)" by auto
  also have "... = reduce a m D A $$ (i,j)" by auto
  also have "... = A $$ (i,j)"
    by (rule reduce_preserves, insert "1", auto)
  finally show ?case .
next
  case (2 a x xs D A)
  note A' = "2.prems"(1)
  note a = "2.prems"(2)
  note j = "2.prems"(3)
  note A_def = "2.prems"(4)
  note Aaj = "2.prems"(5)
  note mn = "2.prems"(6)
  note i_set_xxs = "2.prems"(7)
  note d = "2.prems"(8)
  note xxs_less_m = "2.prems"(9)
  note ia = "2.prems"(10)
  note imm = "2.prems"(11)
  note D_ge0 = "2.prems"(13)
  have D0: "D0" using D_ge0 by simp
  have A: "A  carrier_mat (m+n) n" using A' mn A_def by auto
  have xm: "x < m"  using "2.prems" by auto
  have D1: "D m 1m n  carrier_mat n n" by (simp add: mn)
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "(reduce a x D A)"
  have reduce_ax: "?reduce_ax  carrier_mat (m + n) n"
    by (metis (no_types, lifting) A' A_def add.comm_neutral append_rows_def 
        carrier_matD carrier_mat_triv index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3) reduce_preserves_dimensions)
  have "reduce_below a ((x # xs) @ [m]) D A $$ (i, j) 
      = reduce_below a (xs@[m]) D (reduce a x D A) $$ (i, j)"
    by auto
  also have "... = reduce a x D A $$ (i, j)"
  proof (rule "2.hyps"[OF _ a j _ _ mn _ _ _ ia imm _ D_ge0])
    let ?A' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
    show "reduce a x D A = ?A' @r D m 1m n"
      by (rule reduce_append_rows_eq[OF A' A_def a xm _ Aaj], insert j, auto)  
    show "i  set xs" using i_set_xxs by auto
    show "distinct xs" using d by auto
    show "xset xs. x < m  a < x" using xxs_less_m by auto
    show "reduce a x D A $$ (a, 0)  0"
      by (rule reduce_not0[OF A _ _ _ _ Aaj], insert "2.prems", auto)
    show "?A'  carrier_mat m n" by auto    
    show "im" using "2.prems" by auto
  qed  
  also have "... = A $$ (i,j)" by (rule reduce_preserves[OF A j Aaj], insert "2.prems", auto)
  finally show ?case .
qed


lemma reduce_below_abs_preserves_case_m:
  assumes A': "A'  carrier_mat m n" and a: "a<m" and j: "j<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (a,0)  0"
    and mn: "mn"
  assumes "i  set xs" and "distinct xs" and "x  set xs. x < m  a < x"
    and "ia" and "i<m+n" and "i m"
  and "D>0"
  shows "reduce_below_abs a (xs @ [m]) D A $$ (i,j) = A $$ (i,j)"
  using assms
proof (induct a xs D A arbitrary: A' i rule: reduce_below_abs.induct)
  case (1 a D A)
  have "reduce_below_abs a ([] @ [m]) D A $$ (i, j) = reduce_below_abs a [m] D A $$ (i, j)" by auto
  also have "... = reduce_abs a m D A $$ (i,j)" by auto
  also have "... = A $$ (i,j)"
    by (rule reduce_preserves, insert "1", auto)
  finally show ?case .
next
  case (2 a x xs D A)
  note A' = "2.prems"(1)
  note a = "2.prems"(2)
  note j = "2.prems"(3)
  note A_def = "2.prems"(4)
  note Aaj = "2.prems"(5)
  note mn = "2.prems"(6)
  note i_set_xxs = "2.prems"(7)
  note d = "2.prems"(8)
  note xxs_less_m = "2.prems"(9)
  note ia = "2.prems"(10)
  note imm = "2.prems"(11)
  note D_ge0 = "2.prems"(13)
  have D0: "D0" using D_ge0 by simp
  have A: "A  carrier_mat (m+n) n" using A' mn A_def by auto
  have xm: "x < m"  using "2.prems" by auto
  have D1: "D m 1m n  carrier_mat n n" by (simp add: mn)
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "(reduce_abs a x D A)"
  have reduce_ax: "?reduce_ax  carrier_mat (m + n) n"
    by (metis (no_types, lifting) A' A_def add.comm_neutral append_rows_def 
        carrier_matD carrier_mat_triv index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3) reduce_preserves_dimensions)
  have "reduce_below_abs a ((x # xs) @ [m]) D A $$ (i, j) 
      = reduce_below_abs a (xs@[m]) D (reduce_abs a x D A) $$ (i, j)"
    by auto
  also have "... = reduce_abs a x D A $$ (i, j)"
  proof (rule "2.hyps"[OF _ a j _ _ mn _ _ _ ia imm _ D_ge0])
    let ?A' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
    show "reduce_abs a x D A = ?A' @r D m 1m n"
      by (rule reduce_append_rows_eq[OF A' A_def a xm _ Aaj], insert j, auto)  
    show "i  set xs" using i_set_xxs by auto
    show "distinct xs" using d by auto
    show "xset xs. x < m  a < x" using xxs_less_m by auto
    show "reduce_abs a x D A $$ (a, 0)  0"
      by (rule reduce_not0[OF A _ _ _ _ Aaj], insert "2.prems", auto)
    show "?A'  carrier_mat m n" by auto    
    show "im" using "2.prems" by auto
  qed  
  also have "... = A $$ (i,j)" by (rule reduce_preserves[OF A j Aaj], insert "2.prems", auto)
  finally show ?case .
qed



lemma reduce_below_0_case_m1:
  assumes A': "A'  carrier_mat m n" and a: "a<m" and j: "0<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (a,0)  0"
    and mn: "mn"
  assumes "distinct xs" and "x  set xs. x < m  a < x"
    and "ma"
  and "D>0"
  shows "reduce_below a (xs @ [m]) D A $$ (m,0) = 0"
  using assms
proof (induct a xs D A arbitrary: A' rule: reduce_below.induct)
  case (1 a D A)
  have A: "A  carrier_mat (m+n) n" using "1" by auto
  have " reduce_below a ([] @ [m]) D A $$ (m, 0) =  reduce_below a [m] D A $$ (m, 0)" by auto
  also have "... = reduce a m D A $$ (m,0)" by auto
  also have "... = 0" by (rule reduce_0[OF A], insert "1.prems", auto)
  finally show ?case .
next
  case (2 a x xs D A)
  note A' = "2.prems"(1)
  note a = "2.prems"(2)
  note j = "2.prems"(3)
  note A_def = "2.prems"(4)
  note Aaj = "2.prems"(5)
  note mn = "2.prems"(6)
  note d = "2.prems"(7)
  note xxs_less_m = "2.prems"(8)
  note ma = "2.prems"(9)
  note D_ge0 = "2.prems"(10)
  have D0: "D0" using D_ge0 by simp
  have A: "A  carrier_mat (m+n) n" using A' mn A_def by auto
  have xm: "x < m"  using "2.prems" by auto
  have D1: "D m 1m n  carrier_mat n n" by (simp add: mn)
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "(reduce a x D A)"
  have reduce_ax: "?reduce_ax  carrier_mat (m + n) n"
    by (metis (no_types, lifting) "2" add.comm_neutral append_rows_def 
        carrier_matD carrier_mat_triv index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3) reduce_preserves_dimensions)
  have "reduce_below a ((x # xs) @ [m]) D A $$ (m, 0) = reduce_below a (xs@[m]) D (reduce a x D A) $$ (m, 0)"
    by auto
  also have "... = 0"
  proof (rule "2.hyps"[OF ])
    let ?A' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
    show "reduce a x D A = ?A' @r D m 1m n"
      by (rule reduce_append_rows_eq[OF A' A_def a xm j Aaj])  
    show "distinct xs" using d by auto
    show "xset xs. x < m  a < x" using xxs_less_m by auto
    show "reduce a x D A $$ (a, 0)  0"
      by (rule reduce_not0[OF A _ _ j _ Aaj], insert "2.prems", auto)
    show "?A'  carrier_mat m n" by auto    
  qed (insert "2.prems", auto)
  finally show ?case .
qed

lemma reduce_below_abs_0_case_m1:
  assumes A': "A'  carrier_mat m n" and a: "a<m" and j: "0<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (a,0)  0"
    and mn: "mn"
  assumes "distinct xs" and "x  set xs. x < m  a < x"
    and "ma"
  and "D>0"
  shows "reduce_below_abs a (xs @ [m]) D A $$ (m,0) = 0"
  using assms
proof (induct a xs D A arbitrary: A' rule: reduce_below_abs.induct)
  case (1 a D A)
  have A: "A  carrier_mat (m+n) n" using "1" by auto
  have " reduce_below_abs a ([] @ [m]) D A $$ (m, 0) =  reduce_below_abs a [m] D A $$ (m, 0)" by auto
  also have "... = reduce_abs a m D A $$ (m,0)" by auto
  also have "... = 0" by (rule reduce_0[OF A], insert "1.prems", auto)
  finally show ?case .
next
  case (2 a x xs D A)
  note A' = "2.prems"(1)
  note a = "2.prems"(2)
  note j = "2.prems"(3)
  note A_def = "2.prems"(4)
  note Aaj = "2.prems"(5)
  note mn = "2.prems"(6)
  note d = "2.prems"(7)
  note xxs_less_m = "2.prems"(8)
  note ma = "2.prems"(9)
  note D_ge0 = "2.prems"(10)
  have D0: "D0" using D_ge0 by simp
  have A: "A  carrier_mat (m+n) n" using A' mn A_def by auto
  have xm: "x < m"  using "2.prems" by auto
  have D1: "D m 1m n  carrier_mat n n" by (simp add: mn)
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "(reduce_abs a x D A)"
  have reduce_ax: "?reduce_ax  carrier_mat (m + n) n"
    by (metis (no_types, lifting) "2" add.comm_neutral append_rows_def 
        carrier_matD carrier_mat_triv index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3) reduce_preserves_dimensions)
  have "reduce_below_abs a ((x # xs) @ [m]) D A $$ (m, 0) = reduce_below_abs a (xs@[m]) D (reduce_abs a x D A) $$ (m, 0)"
    by auto
  also have "... = 0"
  proof (rule "2.hyps"[OF ])
    let ?A' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
    show "reduce_abs a x D A = ?A' @r D m 1m n"
      by (rule reduce_append_rows_eq[OF A' A_def a xm j Aaj])  
    show "distinct xs" using d by auto
    show "xset xs. x < m  a < x" using xxs_less_m by auto
    show "reduce_abs a x D A $$ (a, 0)  0"
      by (rule reduce_not0[OF A _ _ j _ Aaj], insert "2.prems", auto)
    show "?A'  carrier_mat m n" by auto    
  qed (insert "2.prems", auto)
  finally show ?case .
qed



lemma reduce_below_preserves_case_m2:
  assumes A': "A'  carrier_mat m n" and a: "a<m" and j: "0<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (a,0)  0"
    and mn: "mn"
  assumes "i  set xs" and "distinct xs" and "x  set xs. x < m  a < x"
    and "ia" and "i<m+n"
  and "D>0"
  shows "reduce_below a (xs @ [m]) D A $$ (i,0) = reduce_below a xs D A $$ (i,0)"
  using assms
proof (induct a xs D A arbitrary: A' i rule: reduce_below.induct)
  case (1 a D A)
  then show ?case by auto
next
  case (2 a x xs D A)
  note A' = "2.prems"(1)
  note a = "2.prems"(2)
  note j = "2.prems"(3)
  note A_def = "2.prems"(4)
  note Aaj = "2.prems"(5)
  note mn = "2.prems"(6)
  note i_set_xxs = "2.prems"(7)
  note d = "2.prems"(8)
  note xxs_less_m = "2.prems"(9)
  note ia = "2.prems"(10)
  note imm = "2.prems"(11)
  note D_ge0 = "2.prems"(12)
  have D0: "D0" using D_ge0 by simp
  have A: "A  carrier_mat (m+n) n" using A' mn A_def by auto
  have xm: "x < m"  using "2.prems" by auto
  have D1: "D m 1m n  carrier_mat n n" by (simp add: mn)
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "(reduce a x D A)"
  have reduce_ax: "?reduce_ax  carrier_mat (m + n) n"
    by (metis (no_types, lifting) A_def A' add.comm_neutral append_rows_def 
        carrier_matD carrier_mat_triv index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3) reduce_preserves_dimensions)
  show ?case
  proof (cases "i=x")
    case True
    have "reduce_below a ((x # xs) @ [m]) D A $$ (i, 0) 
      = reduce_below a (xs @ [m]) D (reduce a x D A) $$ (i, 0)"
      by auto
    also have "... = (reduce a x D A) $$ (i, 0)"
    proof (rule reduce_below_preserves_case_m[OF _ a j _ _ mn _ _ _ _ _ _ D_ge0])
      let ?A' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
      show "reduce a x D A = ?A' @r D m 1m n"
      proof (rule matrix_append_rows_eq_if_preserves[OF reduce_ax D1])
        show "i{m..<m + n}. ja<n. ?reduce_ax $$ (i, ja) = (D m 1m n) $$ (i - m, ja)" 
        proof (rule+)
          fix i ja assume i: "i  {m..<m + n}" and ja: "ja < n"
          have ja_dc: "ja < dim_col A" and i_dr: "i < dim_row A" using i ja A by auto
          have i_not_a: "i  a" using i a by auto
          have i_not_x: "i  x" using i xm by auto
          have "?reduce_ax $$ (i,ja) = A $$ (i,ja)" 
            unfolding reduce_alt_def_not0[OF Aaj pquvd] using ja_dc i_dr i_not_a i_not_x by auto 
          also have "... = (if i < dim_row A' then A' $$(i,ja) else (D m (1m n))$$(i-m,ja))"
            by (unfold A_def, rule append_rows_nth[OF A' D1 _ ja], insert A i_dr, simp)
          also have "... = (D m 1m n) $$ (i - m, ja)" using i A' by auto
          finally show "?reduce_ax $$ (i,ja) = (D m 1m n) $$ (i - m, ja)" .   
        qed
      qed
      show "distinct xs" using d by auto
      show "xset xs. x < m  a < x" using xxs_less_m by auto
      show "reduce a x D A $$ (a, 0)  0"
        by (rule reduce_not0[OF A _ _ _ _ Aaj], insert "2.prems", auto)
      show "?A'  carrier_mat m n" by auto
      show "i  set xs" using True d by auto
      show "i  a" using "2.prems" by blast
      show "i < m + n" 
        by (simp add: True trans_less_add1 xm)
      show "i  m"  by (simp add: True less_not_refl3 xm)
    qed
    also have "... = 0" unfolding True by (rule reduce_0[OF A _ _ _ _ Aaj], insert "2.prems", auto)
    also have "... = reduce_below a (x # xs) D A $$ (i, 0) "
      unfolding True by (rule reduce_below_0[symmetric], insert "2.prems", auto)
    finally show ?thesis .
  next
    case False
    have "reduce_below a ((x # xs) @ [m]) D A $$ (i, 0) 
      = reduce_below a (xs@[m]) D (reduce a x D A) $$ (i, 0)"
      by auto
    also have "... = reduce_below a xs D (reduce a x D A) $$ (i, 0)"
    proof (rule "2.hyps"[OF _ a j _ _ mn _ _ _ ia imm D_ge0])
      let ?A' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
      show "reduce a x D A = ?A' @r D m 1m n"
        by (rule reduce_append_rows_eq[OF A' A_def a xm j Aaj])  
      show "i  set xs" using i_set_xxs False by auto
      show "distinct xs" using d by auto
      show "xset xs. x < m  a < x" using xxs_less_m by auto
      show "reduce a x D A $$ (a, 0)  0"
        by (rule reduce_not0[OF A _ _ j _ Aaj], insert "2.prems", auto)
      show "?A'  carrier_mat m n" by auto    
    qed  
    also have "... = reduce_below a (x # xs) D A $$ (i, 0)" by auto
    finally show ?thesis .
  qed
qed


lemma reduce_below_abs_preserves_case_m2:
  assumes A': "A'  carrier_mat m n" and a: "a<m" and j: "0<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (a,0)  0"
    and mn: "mn"
  assumes "i  set xs" and "distinct xs" and "x  set xs. x < m  a < x"
    and "ia" and "i<m+n"
  and "D>0"
  shows "reduce_below_abs a (xs @ [m]) D A $$ (i,0) = reduce_below_abs a xs D A $$ (i,0)"
  using assms
proof (induct a xs D A arbitrary: A' i rule: reduce_below_abs.induct)
  case (1 a D A)
  then show ?case by auto
next
  case (2 a x xs D A)
  note A' = "2.prems"(1)
  note a = "2.prems"(2)
  note j = "2.prems"(3)
  note A_def = "2.prems"(4)
  note Aaj = "2.prems"(5)
  note mn = "2.prems"(6)
  note i_set_xxs = "2.prems"(7)
  note d = "2.prems"(8)
  note xxs_less_m = "2.prems"(9)
  note ia = "2.prems"(10)
  note imm = "2.prems"(11)
  note D_ge0 = "2.prems"(12)
  have D0: "D0" using D_ge0 by simp
  have A: "A  carrier_mat (m+n) n" using A' mn A_def by auto
  have xm: "x < m"  using "2.prems" by auto
  have D1: "D m 1m n  carrier_mat n n" by (simp add: mn)
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "(reduce_abs a x D A)"
  have reduce_ax: "?reduce_ax  carrier_mat (m + n) n"
    by (metis (no_types, lifting) A_def A' add.comm_neutral append_rows_def 
        carrier_matD carrier_mat_triv index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3) reduce_preserves_dimensions)
  show ?case
  proof (cases "i=x")
    case True
    have "reduce_below_abs a ((x # xs) @ [m]) D A $$ (i, 0) 
      = reduce_below_abs a (xs @ [m]) D (reduce_abs a x D A) $$ (i, 0)"
      by auto
    also have "... = (reduce_abs a x D A) $$ (i, 0)"
    proof (rule reduce_below_abs_preserves_case_m[OF _ a j _ _ mn _ _ _ _ _ _ D_ge0])
      let ?A' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
      show "reduce_abs a x D A = ?A' @r D m 1m n"
      proof (rule matrix_append_rows_eq_if_preserves[OF reduce_ax D1])
        show "i{m..<m + n}. ja<n. ?reduce_ax $$ (i, ja) = (D m 1m n) $$ (i - m, ja)" 
        proof (rule+)
          fix i ja assume i: "i  {m..<m + n}" and ja: "ja < n"
          have ja_dc: "ja < dim_col A" and i_dr: "i < dim_row A" using i ja A by auto
          have i_not_a: "i  a" using i a by auto
          have i_not_x: "i  x" using i xm by auto
          have "?reduce_ax $$ (i,ja) = A $$ (i,ja)" 
            unfolding reduce_alt_def_not0[OF Aaj pquvd] using ja_dc i_dr i_not_a i_not_x by auto 
          also have "... = (if i < dim_row A' then A' $$(i,ja) else (D m (1m n))$$(i-m,ja))"
            by (unfold A_def, rule append_rows_nth[OF A' D1 _ ja], insert A i_dr, simp)
          also have "... = (D m 1m n) $$ (i - m, ja)" using i A' by auto
          finally show "?reduce_ax $$ (i,ja) = (D m 1m n) $$ (i - m, ja)" .   
        qed
      qed
      show "distinct xs" using d by auto
      show "xset xs. x < m  a < x" using xxs_less_m by auto
      show "reduce_abs a x D A $$ (a, 0)  0"
        by (rule reduce_not0[OF A _ _ _ _ Aaj], insert "2.prems", auto)
      show "?A'  carrier_mat m n" by auto
      show "i  set xs" using True d by auto
      show "i  a" using "2.prems" by blast
      show "i < m + n" 
        by (simp add: True trans_less_add1 xm)
      show "i  m"  by (simp add: True less_not_refl3 xm)
    qed
    also have "... = 0" unfolding True by (rule reduce_0[OF A _ _ _ _ Aaj], insert "2.prems", auto)
    also have "... = reduce_below_abs a (x # xs) D A $$ (i, 0) "
      unfolding True by (rule reduce_below_abs_0[symmetric], insert "2.prems", auto)
    finally show ?thesis .
  next
    case False
    have "reduce_below_abs a ((x # xs) @ [m]) D A $$ (i, 0) 
      = reduce_below_abs a (xs@[m]) D (reduce_abs a x D A) $$ (i, 0)"
      by auto
    also have "... = reduce_below_abs a xs D (reduce_abs a x D A) $$ (i, 0)"
    proof (rule "2.hyps"[OF _ a j _ _ mn _ _ _ ia imm D_ge0])
      let ?A' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
      show "reduce_abs a x D A = ?A' @r D m 1m n"
        by (rule reduce_append_rows_eq[OF A' A_def a xm j Aaj])  
      show "i  set xs" using i_set_xxs False by auto
      show "distinct xs" using d by auto
      show "xset xs. x < m  a < x" using xxs_less_m by auto
      show "reduce_abs a x D A $$ (a, 0)  0"
        by (rule reduce_not0[OF A _ _ j _ Aaj], insert "2.prems", auto)
      show "?A'  carrier_mat m n" by auto    
    qed  
    also have "... = reduce_below_abs a (x # xs) D A $$ (i, 0)" by auto
    finally show ?thesis .
  qed
qed


lemma reduce_below_0_case_m:
  assumes A': "A'  carrier_mat m n" and a: "a<m" and j: "0<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (a,0)  0"
    and mn: "mn"
  assumes "i  set (xs @ [m])" and "distinct xs" and "x  set xs. x < m  a < x"
  and "D>0"
  shows "reduce_below a (xs @ [m]) D A $$ (i,0) = 0"
proof (cases "i=m")
  case True
  show ?thesis by (unfold True, rule reduce_below_0_case_m1, insert assms, auto)
next
  case False
  have "reduce_below a (xs @ [m]) D A $$ (i,0) = reduce_below a (xs) D A $$ (i,0)"
    by (rule reduce_below_preserves_case_m2[OF A' a j A_def Aaj mn], insert assms False, auto) 
  also have "... = 0" by (rule reduce_below_0, insert assms False, auto)
  finally show ?thesis .
qed


lemma reduce_below_abs_0_case_m:
  assumes A': "A'  carrier_mat m n" and a: "a<m" and j: "0<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (a,0)  0"
    and mn: "mn"
  assumes "i  set (xs @ [m])" and "distinct xs" and "x  set xs. x < m  a < x"
  and "D>0"
  shows "reduce_below_abs a (xs @ [m]) D A $$ (i,0) = 0"
proof (cases "i=m")
  case True
  show ?thesis by (unfold True, rule reduce_below_abs_0_case_m1, insert assms, auto)
next
  case False
  have "reduce_below_abs a (xs @ [m]) D A $$ (i,0) = reduce_below_abs a (xs) D A $$ (i,0)"
    by (rule reduce_below_abs_preserves_case_m2[OF A' a j A_def Aaj mn], insert assms False, auto) 
  also have "... = 0" by (rule reduce_below_abs_0, insert assms False, auto)
  finally show ?thesis .
qed


lemma reduce_below_0_case_m_complete:
  assumes A': "A'  carrier_mat m n" and a: "0<m" and j: "0<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (0,0)  0"
    and mn: "mn"
  assumes i_mn: "i < m+n" and d_xs: "distinct xs" and xs: "x  set xs. x < m  0 < x"
    and ia: "i0"
  and xs_def: "xs = filter (λi. A $$ (i,0)  0) [1..<dim_row A]"
  and D: "D>0"
  shows "reduce_below 0 (xs @ [m]) D A $$ (i,0) = 0"
proof (cases "i  set (xs @ [m])")
  case True
  show ?thesis by (rule reduce_below_0_case_m[OF A' a j A_def Aaj mn True d_xs xs D])
next
  case False
  have A: "A  carrier_mat (m+n) n" using A' A_def by simp
  have "reduce_below 0 (xs @ [m]) D A $$ (i,0) = A $$ (i,0)"    
    by (rule reduce_below_preserves_case_m[OF A' a j A_def Aaj mn _ _ _ _ _ _ D],
        insert i_mn d_xs xs ia False, auto) 
  also have "... = 0"  using False ia i_mn A unfolding xs_def by auto    
  finally show ?thesis .
qed



lemma reduce_below_abs_0_case_m_complete:
  assumes A': "A'  carrier_mat m n" and a: "0<m" and j: "0<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (0,0)  0"
    and mn: "mn"
  assumes i_mn: "i < m+n" and d_xs: "distinct xs" and xs: "x  set xs. x < m  0 < x"
    and ia: "i0"
  and xs_def: "xs = filter (λi. A $$ (i,0)  0) [1..<dim_row A]"
  and D: "D>0"
  shows "reduce_below_abs 0 (xs @ [m]) D A $$ (i,0) = 0"
proof (cases "i  set (xs @ [m])")
  case True
  show ?thesis by (rule reduce_below_abs_0_case_m[OF A' a j A_def Aaj mn True d_xs xs D])
next
  case False
  have A: "A  carrier_mat (m+n) n" using A' A_def by simp
  have "reduce_below_abs 0 (xs @ [m]) D A $$ (i,0) = A $$ (i,0)"    
    by (rule reduce_below_abs_preserves_case_m[OF A' a j A_def Aaj mn _ _ _ _ _ _ D],
        insert i_mn d_xs xs ia False, auto) 
  also have "... = 0"  using False ia i_mn A unfolding xs_def by auto    
  finally show ?thesis .
qed


(*Now we take care of the mth row of A*)
lemma reduce_below_invertible_mat_case_m:
  assumes A': "A'  carrier_mat m n" and a: "a<m" and n0: "0<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (a,0)  0"
    and mn: "mn" and "distinct xs" and "x  set xs. x < m  a < x" 
    and D0: "D>0"
  shows "(P. invertible_mat P  P  carrier_mat (m+n) (m+n)  reduce_below a (xs@[m]) D A = P * A)"
  using assms
proof (induct a xs D A arbitrary: A' rule: reduce_below.induct)
  case (1 a D A)
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(m,0))"
    by (metis prod_cases5)
  have D: "D m (1m n) : carrier_mat n n" by auto
  note A' = "1.prems"(1)
  note a = "1.prems"(2)
  note j = "1.prems"(3)
  note A_def = "1.prems"(4)
  note Aaj = "1.prems"(5)
  note mn = "1.prems"(6)  
  note D0 = "1.prems"(9)
  have Am0_D: "A $$ (m, 0) = D"
  proof -
    have "A $$ (m, 0) = (D m (1m n)) $$ (m-m,0)"
      by (smt (z3) "1"(1) "1"(3) "1"(4) D append_rows_nth3 diff_is_0_eq diff_self_eq_0 less_add_same_cancel1)
    also have "... = D" by (simp add: n0)
    finally show ?thesis .
  qed
  have "reduce_below a ([]@[m]) D A = reduce a m D A" by auto
  let ?A = "Matrix.mat (dim_row A) (dim_col A) 
      (λ(i, k). if i = a then p * A $$ (a, k) + q * A $$ (m, k) else 
        if i = m then u * A $$ (a, k) + v * A $$ (m, k) else A $$ (i, k))"
  let ?xs = "[1..<n]"
  let ?ys = "[1..<n]"  
  have "P. invertible_mat P  P  carrier_mat (m + n) (m + n)  reduce a m D A = P * A"
    by (rule reduce_invertible_mat_case_m[OF A' D a _ A_def _ Aaj mn n0 pquvd, of ?xs _ _ ?ys],
        insert a D0 Am0_D, auto)
  then show ?case by auto
next
  case (2 a x xs D A)
  note A' = "2.prems"(1)
  note a = "2.prems"(2)
  note n0 = "2.prems"(3)
  note A_def = "2.prems"(4)
  note Aaj = "2.prems"(5)
  note mn = "2.prems"(6)
  note d = "2.prems"(7)
  note xxs_less_m = "2.prems"(8)
  note D0 = "2.prems"(9)
  have A: "A  carrier_mat (m+n) n" using A' mn A_def by auto
  have xm: "x < m"  using "2.prems" by auto
  have D1: "D m 1m n  carrier_mat n n" by (simp add: mn)
  have Am0_D: "A $$ (m, 0) = D"
  proof -
    have "A $$ (m, 0) = (D m (1m n)) $$ (m-m,0)"
      by (smt (z3) "2"(2) "2"(4) "2"(5) D1 append_rows_nth3 
          cancel_comm_monoid_add_class.diff_cancel diff_is_0_eq less_add_same_cancel1)
    also have "... = D" by (simp add: n0)
    finally show ?thesis .
  qed
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "reduce a x D A"
  have reduce_ax: "?reduce_ax  carrier_mat (m + n) n"
    by (metis (no_types, lifting) "2" add.comm_neutral append_rows_def 
        carrier_matD carrier_mat_triv index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3) reduce_preserves_dimensions)
  have h: "(P. invertible_mat P  P  carrier_mat (m + n) (m + n) 
     reduce_below a (xs@[m]) D (reduce a x D A) = P * reduce a x D A)"
  proof (rule "2.hyps"[OF _ a n0 _ _ ])
    let ?A' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
    show "reduce a x D A = ?A' @r D m 1m n"
      by (rule reduce_append_rows_eq[OF A' A_def a xm n0 Aaj])  
    show "reduce a x D A $$ (a, 0)  0"
      by (rule reduce_not0[OF A _ _ n0 _ Aaj], insert "2.prems", auto)
  qed (insert d xxs_less_m mn n0 D0, auto)
  from this obtain P where inv_P: "invertible_mat P" and P: "P  carrier_mat (m + n) (m + n)"
    and rb_Pr: "reduce_below a (xs@[m]) D (reduce a x D A) = P * reduce a x D A" by blast
  have *: "reduce_below a ((x # xs)@[m]) D A = reduce_below a (xs@[m]) D (reduce a x D A)" by simp
  have "Q. invertible_mat Q  Q  carrier_mat (m+n) (m+n)  (reduce a x D A) = Q * A"
    by (rule reduce_invertible_mat[OF A' a n0 xm _ A_def Aaj _ mn D0], insert xxs_less_m, auto)
  from this obtain Q where inv_Q: "invertible_mat Q" and Q: "Q  carrier_mat (m + n) (m + n)"
    and r_QA: "reduce a x D A = Q * A" by blast
  have "invertible_mat (P*Q)" using inv_P inv_Q P Q invertible_mult_JNF by blast
  moreover have "P * Q  carrier_mat (m+n) (m+n)" using P Q by auto
  moreover have "reduce_below a ((x # xs)@[m]) D A = (P*Q) * A" 
    by (smt P Q * assoc_mult_mat carrier_matD(1) carrier_mat_triv index_mult_mat(2) 
        r_QA rb_Pr reduce_preserves_dimensions(1))
  ultimately show ?case by blast
qed




(*Now we take care of the mth row of A*)
lemma reduce_below_abs_invertible_mat_case_m:
  assumes A': "A'  carrier_mat m n" and a: "a<m" and n0: "0<n"
    and A_def: "A = A' @r (D m (1m n))"
    and Aaj: "A $$ (a,0)  0"
    and mn: "mn" and "distinct xs" and "x  set xs. x < m  a < x" 
    and D0: "D>0"
  shows "(P. invertible_mat P  P  carrier_mat (m+n) (m+n)  reduce_below_abs a (xs@[m]) D A = P * A)"
  using assms
proof (induct a xs D A arbitrary: A' rule: reduce_below_abs.induct)
  case (1 a D A)
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(m,0))"
    by (metis prod_cases5)
  have D: "D m (1m n) : carrier_mat n n" by auto
  note A' = "1.prems"(1)
  note a = "1.prems"(2)
  note j = "1.prems"(3)
  note A_def = "1.prems"(4)
  note Aaj = "1.prems"(5)
  note mn = "1.prems"(6)  
  note D0 = "1.prems"(9)
  have Am0_D: "A $$ (m, 0) = D"
  proof -
    have "A $$ (m, 0) = (D m (1m n)) $$ (m-m,0)"
      by (smt (z3) "1"(1) "1"(3) "1"(4) D append_rows_nth3 diff_is_0_eq diff_self_eq_0 less_add_same_cancel1)
    also have "... = D" by (simp add: n0)
    finally show ?thesis .
  qed
  have "reduce_below_abs a ([]@[m]) D A = reduce_abs a m D A" by auto
  let ?A = "Matrix.mat (dim_row A) (dim_col A) 
      (λ(i, k). if i = a then p * A $$ (a, k) + q * A $$ (m, k) else 
        if i = m then u * A $$ (a, k) + v * A $$ (m, k) else A $$ (i, k))"
  let ?xs = "filter (λi. D < ¦?A $$ (a, i)¦) [0..<n]"
  let ?ys = "filter (λi. D < ¦?A $$ (m, i)¦) [0..<n]"  
  have "P. invertible_mat P  P  carrier_mat (m + n) (m + n)  reduce_abs a m D A = P * A"
    by (rule reduce_abs_invertible_mat_case_m[OF A' D a _ A_def _ Aaj mn n0 pquvd, of ?xs _ _ ?ys],
        insert a D0 Am0_D, auto)
  then show ?case by auto
next
  case (2 a x xs D A)
  note A' = "2.prems"(1)
  note a = "2.prems"(2)
  note n0 = "2.prems"(3)
  note A_def = "2.prems"(4)
  note Aaj = "2.prems"(5)
  note mn = "2.prems"(6)
  note d = "2.prems"(7)
  note xxs_less_m = "2.prems"(8)
  note D0 = "2.prems"(9)
  have A: "A  carrier_mat (m+n) n" using A' mn A_def by auto
  have xm: "x < m"  using "2.prems" by auto
  have D1: "D m 1m n  carrier_mat n n" by (simp add: mn)
  have Am0_D: "A $$ (m, 0) = D"
  proof -
    have "A $$ (m, 0) = (D m (1m n)) $$ (m-m,0)"
      by (smt (z3) "2"(2) "2"(4) "2"(5) D1 append_rows_nth3 
          cancel_comm_monoid_add_class.diff_cancel diff_is_0_eq less_add_same_cancel1)
    also have "... = D" by (simp add: n0)
    finally show ?thesis .
  qed
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "reduce_abs a x D A"
  have reduce_ax: "?reduce_ax  carrier_mat (m + n) n"
    by (metis (no_types, lifting) "2" add.comm_neutral append_rows_def 
        carrier_matD carrier_mat_triv index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3) reduce_preserves_dimensions)
  have h: "(P. invertible_mat P  P  carrier_mat (m + n) (m + n) 
     reduce_below_abs a (xs@[m]) D (reduce_abs a x D A) = P * reduce_abs a x D A)"
  proof (rule "2.hyps"[OF _ a n0 _ _ ])
    let ?A' = "mat_of_rows n (map (Matrix.row ?reduce_ax) [0..<m])"
    show "reduce_abs a x D A = ?A' @r D m 1m n"
      by (rule reduce_append_rows_eq[OF A' A_def a xm n0 Aaj])  
    show "reduce_abs a x D A $$ (a, 0)  0"
      by (rule reduce_not0[OF A _ _ n0 _ Aaj], insert "2.prems", auto)
  qed (insert d xxs_less_m mn n0 D0, auto)
  from this obtain P where inv_P: "invertible_mat P" and P: "P  carrier_mat (m + n) (m + n)"
    and rb_Pr: "reduce_below_abs a (xs@[m]) D (reduce_abs a x D A) = P * reduce_abs a x D A" by blast
  have *: "reduce_below_abs a ((x # xs)@[m]) D A = reduce_below_abs a (xs@[m]) D (reduce_abs a x D A)" by simp
  have "Q. invertible_mat Q  Q  carrier_mat (m+n) (m+n)  (reduce_abs a x D A) = Q * A"
    by (rule reduce_abs_invertible_mat[OF A' a n0 xm _ A_def Aaj _ mn D0], insert xxs_less_m, auto)
  from this obtain Q where inv_Q: "invertible_mat Q" and Q: "Q  carrier_mat (m + n) (m + n)"
    and r_QA: "reduce_abs a x D A = Q * A" by blast
  have "invertible_mat (P*Q)" using inv_P inv_Q P Q invertible_mult_JNF by blast
  moreover have "P * Q  carrier_mat (m+n) (m+n)" using P Q by auto
  moreover have "reduce_below_abs a ((x # xs)@[m]) D A = (P*Q) * A" 
    by (smt P Q * assoc_mult_mat carrier_matD(1) carrier_mat_triv index_mult_mat(2) 
        r_QA rb_Pr reduce_preserves_dimensions(3))
  ultimately show ?case by blast
qed

end

hide_const (open) C

text ‹This lemma will be very important, since it will allow us to prove that the output
matrix is in echelon form.›

lemma echelon_form_four_block_mat:
  assumes A: "A  carrier_mat 1 1"
  and B: "B  carrier_mat 1 (n-1)"
  and D: "D  carrier_mat (m-1) (n-1)"
  and H_def: "H = four_block_mat A B (0m (m-1) 1) D"
  and A00: "A $$ (0,0)  0"
  and e_D: "echelon_form_JNF D"
  and m: "m>0" and n: "n>0"
shows "echelon_form_JNF H"
proof (rule echelon_form_JNF_intro)
  have H: "H  carrier_mat m n"
    by (metis H_def Num.numeral_nat(7) A D m n carrier_matD carrier_mat_triv
        index_mat_four_block(2,3) linordered_semidom_class.add_diff_inverse not_less_eq)
  have Hij_Dij: "H $$ (i+1,j+1) = D $$ (i,j)" if i: "i<m-1" and j: "j<n-1" for i j
  proof -
    have "H $$ (i+1,j+1) =  (if (i+1) < dim_row A then if (j+1) < dim_col A then A $$ ((i+1), (j+1)) 
    else B $$ ((i+1), (j+1) - dim_col A) else if (j+1) < dim_col A then 
    (0m (m-1) 1) $$ ((i+1) - dim_row A, (j+1)) else D $$ ((i+1) - dim_row A, (j+1) - dim_col A))"
      unfolding H_def by (rule index_mat_four_block, insert A D i j, auto)
    also have "... = D $$ ((i+1) - dim_row A, (j+1) - dim_col A)" using A D i j B m n by auto
    also have "... = D $$ (i,j)" using A by auto
    finally show ?thesis .
  qed
  have Hij_Dij':  "H $$ (i,j) = D $$ (i-1,j-1)" 
    if i: "i<m" and j: "j<n" and i0: "i>0" and j0: "j>0" for i j
    by (metis (no_types, lifting) H H_def Num.numeral_nat(7) A carrier_matD 
        index_mat_four_block less_Suc0 less_not_refl3 i j i0 j0)
  have Hi0: "H$$(i,0) = 0" if i: "i{1..<m}" for i
  proof -
    have "H $$ (i,0) =  (if i < dim_row A then if 0 < dim_col A then A $$ (i, 0) 
      else B $$ (i, 0 - dim_col A) else if 0 < dim_col A then 
      (0m (m-1) 1) $$ (i - dim_row A, 0) else D $$ (i - dim_row A, 0 - dim_col A))"
      unfolding H_def by (rule index_mat_four_block, insert A D i, auto)
    also have "... = (0m (m-1) 1) $$ (i - dim_row A, 0)" using A D i m n by auto
    also have "... = 0" using i A n by auto
    finally show ?thesis .
  qed
  have A00_H00: "A $$ (0,0) = H $$ (0,0)" unfolding H_def using A by auto
  have "is_zero_row_JNF j H" if zero_iH: "is_zero_row_JNF i H" and ij: "i < j" and j: "j < dim_row H"
    for i j 
  proof -
    have "¬ is_zero_row_JNF 0 H" unfolding is_zero_row_JNF_def using m n H A00 A00_H00 by auto
    hence i_not0: "i0" using zero_iH by meson
    have "is_zero_row_JNF (i-1) D" using zero_iH i_not0 Hij_Dij m n D H unfolding is_zero_row_JNF_def
      by (auto, smt (z3) Suc_leI carrier_matD(1) le_add_diff_inverse2 Hij_Dij One_nat_def Suc_pred carrier_matD(1) j le_add_diff_inverse2
          less_diff_conv less_imp_add_positive plus_1_eq_Suc that(2) trans_less_add1)
    hence "is_zero_row_JNF (j-1) D" using ij e_D D j m i_not0 unfolding echelon_form_JNF_def
      by (auto, smt H Nat.lessE Suc_pred carrier_matD(1) diff_Suc_1 diff_Suc_less order.strict_trans)
    thus ?thesis
      by (smt A H H_def Hi0 D atLeastLessThan_iff carrier_matD index_mat_four_block(1)
          is_zero_row_JNF_def le_add1 less_one linordered_semidom_class.add_diff_inverse not_less_eq
          plus_1_eq_Suc ij j zero_order(3))
  qed
  thus "i<dim_row H. is_zero_row_JNF i H  ¬ (j<dim_row H. i < j  ¬ is_zero_row_JNF j H)"
    by blast
  have "(LEAST n. H $$ (i, n)  0) < (LEAST n. H $$ (j, n)  0)"
    if ij: "i < j" and j: "j < dim_row H" and not_zero_iH: "¬ is_zero_row_JNF i H" 
    and not_zero_jH: "¬ is_zero_row_JNF j H" for i j
  proof (cases "i = 0")
    case True
    have "(LEAST n. H $$ (i, n)  0) = 0" unfolding True using A00_H00 A00 by auto
    then show ?thesis
      by (metis (mono_tags) H Hi0 LeastI True atLeastLessThan_iff carrier_matD(1) 
          is_zero_row_JNF_def leI less_one not_gr0 ij j not_zero_jH)
  next
    case False note i_not0 = False
    let ?least_H = "(LEAST n. H $$ (i, n)  0)"
    let ?least_Hj = "(LEAST n. H $$ (j, n)  0)"

    have least_not0: "(LEAST n. H $$ (i, n)  0)  0" 
    proof -
      have "n. H $$ (i, n)  0  H $$ (i, 0) = 0"
        by (metis (no_types) False H Hi0 Num.numeral_nat(7) atLeastLessThan_iff carrier_matD(1)
            is_zero_row_JNF_def j nat_LEAST_True nat_neq_iff not_less_Least not_less_eq order.strict_trans
            ij not_zero_iH wellorder_Least_lemma(1) wellorder_Least_lemma(2))
      then show ?thesis
        by (metis (mono_tags, lifting) LeastI_ex)
    qed
    have least_not0j: "(LEAST n. H $$ (j, n)  0)  0"
    proof -
      have "n. H $$ (j, 0) = 0  H $$ (j, n)  0"
        by (metis (no_types) H Hi0 LeastI_ex Num.numeral_nat(7) atLeastLessThan_iff carrier_matD(1)
            is_zero_row_JNF_def linorder_neqE_nat not_gr0 not_less_Least not_less_eq order_trans_rules(19)
            ij j not_zero_jH wellorder_Least_lemma(2))
      then show ?thesis
        by (metis (mono_tags, lifting) LeastI_ex)
    qed
    have least_n: "?least_H<n"
      by (smt H carrier_matD(2) dual_order.strict_trans is_zero_row_JNF_def 
          not_less_Least not_less_iff_gr_or_eq not_zero_iH)
    have Hil: "H $$ (i,?least_H)  0" and ln':"(n'. (H $$ (i, n')  0)  ?least_H  n')" 
      by (metis (mono_tags, lifting) is_zero_row_JNF_def that(3) wellorder_Least_lemma)+
    have Hil_Dil: "H $$ (i,?least_H) = D $$ (i-1,?least_H - 1)"      
    proof -
      have "H $$ (i,?least_H) = (if i < dim_row A then if ?least_H < dim_col A then A $$ (i, ?least_H) 
      else B $$ (i, ?least_H - dim_col A) else if ?least_H < dim_col A then 
      (0m (m-1) 1) $$ (i - dim_row A, ?least_H) else D $$ (i - dim_row A, ?least_H - dim_col A))"
        unfolding H_def
        by (rule index_mat_four_block, insert False j ij H A D n least_n, auto simp add: H_def)
      also have "... = D $$ (i - 1, ?least_H - 1)"
        using False j ij H A D n least_n B Hi0 Hil by auto
      finally show ?thesis .
    qed
    have not_zero_iD: "¬ is_zero_row_JNF (i-1) D" 
      by (metis (no_types, lifting) Hil Hil_Dil D carrier_matD(2) is_zero_row_JNF_def le_add1 
          le_add_diff_inverse2 least_n least_not0 less_diff_conv less_one
          linordered_semidom_class.add_diff_inverse)
    have not_zero_jD: "¬ is_zero_row_JNF (j-1) D"
      by (smt H Hij_Dij' One_nat_def Suc_pred D m carrier_matD diff_Suc_1 ij is_zero_row_JNF_def j
          least_not0j less_Suc0 less_Suc_eq_0_disj less_one neq0_conv not_less_Least not_less_eq
          plus_1_eq_Suc not_zero_jH zero_order(3))
    have "?least_H - 1 = (LEAST n. D $$ (i-1, n)  0  n<dim_col D)"
    proof (rule Least_equality[symmetric], rule)
      show "D $$ (i - 1, ?least_H - 1)  0" using Hil Hil_Dil by auto
      show "(LEAST n. H $$ (i, n)  0) - 1 < dim_col D" using least_n least_not0 H D n by auto
      fix n' assume "D $$ (i - 1, n')  0  n' < dim_col D" 
      hence Di1n'1: "D $$ (i - 1, n')  0" and n': "n' < dim_col D" by auto
      have "(LEAST n. H $$ (i, n)  0)  n' + 1"
      proof (rule Least_le)
        have "H $$ (i, n'+1) = D $$ (i -1, (n'+1)-1)"
          by (rule Hij_Dij', insert i_not0 False H A ij j n' D, auto)
        thus Hin': "H $$ (i, n'+1)  0" using False Di1n'1 Hij_Dij' by auto
      qed
      thus  "(LEAST n. H $$ (i, n)  0) -1  n'" using least_not0 by auto
    qed
    also have "... = (LEAST n. D $$ (i-1, n)  0)"
    proof (rule Least_equality)
      have "D $$ (i - 1, LEAST n. D $$ (i - 1, n)  0)  0" 
        by (metis (mono_tags, lifting) Hil Hil_Dil LeastI_ex)
      moreover have leastD: "(LEAST n. D $$ (i - 1, n)  0) < dim_col D"
        by (smt dual_order.strict_trans is_zero_row_JNF_def linorder_neqE_nat
            not_less_Least not_zero_iD) 
      ultimately show "D $$ (i - 1, LEAST n. D $$ (i - 1, n)  0)  0 
         (LEAST n. D $$ (i - 1, n)  0) < dim_col D" by simp  
      fix y assume "D $$ (i - 1, y)  0  y < dim_col D" 
      thus "(LEAST n. D $$ (i - 1, n)  0)  y" by (meson wellorder_Least_lemma(2))
    qed
    finally have leastHi_eq: "?least_H - 1 = (LEAST n. D $$ (i-1, n)  0)" .
    have least_nj: "?least_Hj<n"
      by (smt H carrier_matD(2) dual_order.strict_trans is_zero_row_JNF_def 
          not_less_Least not_less_iff_gr_or_eq not_zero_jH)
    have Hjl: "H $$ (j,?least_Hj)  0" and ln':"(n'. (H $$ (j, n')  0)  ?least_Hj  n')" 
      by (metis (mono_tags, lifting) is_zero_row_JNF_def not_zero_jH wellorder_Least_lemma)+
    have Hjl_Djl: "H $$ (j,?least_Hj) = D $$ (j-1,?least_Hj - 1)"      
    proof -
      have "H $$ (j,?least_Hj) = (if j < dim_row A then if ?least_Hj < dim_col A then A $$ (j, ?least_Hj) 
      else B $$ (j, ?least_Hj - dim_col A) else if ?least_Hj < dim_col A then 
      (0m (m-1) 1) $$ (j - dim_row A, ?least_Hj) else D $$ (j - dim_row A, ?least_Hj - dim_col A))"
        unfolding H_def
        by (rule index_mat_four_block, insert False j ij H A D n least_nj, auto simp add: H_def)
      also have "... = D $$ (j - 1, ?least_Hj - 1)"
        using False j ij H A D n least_n B Hi0 Hjl by auto
      finally show ?thesis .
    qed
    have "(LEAST n. H $$ (j, n)  0) - 1 = (LEAST n. D $$ (j-1, n)  0  n<dim_col D)"
    proof (rule Least_equality[symmetric], rule)
      show "D $$ (j - 1, ?least_Hj - 1)  0" using Hil Hil_Dil
        by (smt H Hij_Dij' LeastI_ex carrier_matD is_zero_row_JNF_def j least_not0j 
            linorder_neqE_nat not_gr0 not_less_Least order.strict_trans ij not_zero_jH)
      show "(LEAST n. H $$ (j, n)  0) - 1 < dim_col D" using least_nj least_not0j H D n by auto
      fix n' assume "D $$ (j - 1, n')  0  n' < dim_col D" 
      hence Di1n'1: "D $$ (j - 1, n')  0" and n': "n' < dim_col D" by auto
      have "(LEAST n. H $$ (j, n)  0)  n' + 1"
      proof (rule Least_le)
        have "H $$ (j, n'+1) = D $$ (j -1, (n'+1)-1)"
          by (rule Hij_Dij', insert i_not0 False H A ij j n' D, auto)
        thus Hin': "H $$ (j, n'+1)  0" using False Di1n'1 Hij_Dij' by auto
      qed
      thus  "(LEAST n. H $$ (j, n)  0) -1  n'" using least_not0 by auto
    qed
    also have "... = (LEAST n. D $$ (j-1, n)  0)"
    proof (rule Least_equality)
      have "D $$ (j - 1, LEAST n. D $$ (j - 1, n)  0)  0" 
        by (metis (mono_tags, lifting) Hjl Hjl_Djl LeastI_ex)
      moreover have leastD: "(LEAST n. D $$ (j - 1, n)  0) < dim_col D"
        by (smt dual_order.strict_trans is_zero_row_JNF_def linorder_neqE_nat
            not_less_Least not_zero_jD) 
      ultimately show "D $$ (j - 1, LEAST n. D $$ (j - 1, n)  0)  0 
         (LEAST n. D $$ (j - 1, n)  0) < dim_col D" by simp  
      fix y assume "D $$ (j - 1, y)  0  y < dim_col D" 
      thus "(LEAST n. D $$ (j - 1, n)  0)  y" by (meson wellorder_Least_lemma(2))
    qed
    finally have leastHj_eq: "(LEAST n. H $$ (j, n)  0) - 1 = (LEAST n. D $$ (j-1, n)  0)" .
    have ij': "i-1 < j-1" using ij False by auto
    have "j-1 < dim_row D "  using D H ij j by auto
    hence "(LEAST n. D $$ (i-1, n)  0) < (LEAST n. D $$ (j-1, n)  0)" 
      using e_D echelon_form_JNF_def ij' not_zero_jD order.strict_trans by blast    
    thus ?thesis using leastHj_eq leastHi_eq by auto
  qed
  thus "i j. i < j  j < dim_row H  ¬ is_zero_row_JNF i H  ¬ is_zero_row_JNF j H 
   (LEAST n. H $$ (i, n)  0) < (LEAST n. H $$ (j, n)  0)" by blast    
qed

context mod_operation
begin


lemma reduce_below:
  assumes "A  carrier_mat m n"
  shows "reduce_below a xs D A  carrier_mat m n" 
  using assms 
  by (induct a xs D A rule: reduce_below.induct, auto simp add: Let_def euclid_ext2_def) 

lemma reduce_below_preserves_dimensions:
 shows [simp]: "dim_row (reduce_below a xs D A) = dim_row A" 
    and [simp]: "dim_col (reduce_below a xs D A) = dim_col A"
  using reduce_below[of A "dim_row A" "dim_col A"] by auto


lemma reduce_below_abs:
  assumes "A  carrier_mat m n"
  shows "reduce_below_abs a xs D A  carrier_mat m n" 
  using assms 
  by (induct a xs D A rule: reduce_below_abs.induct, auto simp add: Let_def euclid_ext2_def) 

lemma reduce_below_abs_preserves_dimensions:
 shows [simp]: "dim_row (reduce_below_abs a xs D A) = dim_row A" 
    and [simp]: "dim_col (reduce_below_abs a xs D A) = dim_col A"
  using reduce_below_abs[of A "dim_row A" "dim_col A"] by auto


lemma FindPreHNF_1xn:
 assumes A: "A  carrier_mat m n" and "m<2  n = 0"
 shows "FindPreHNF abs_flag D A  carrier_mat m n" using assms by auto

lemma FindPreHNF_mx1:
 assumes A: "A  carrier_mat m n" and "m2" and "n  0" "n<2"
 shows "FindPreHNF abs_flag D A  carrier_mat m n"
proof (cases "abs_flag")
  case True
  let ?nz = "(filter (λi. A $$ (i, 0)  0) [1..<m])"
  have "FindPreHNF abs_flag D A =  (let non_zero_positions = filter (λi. A $$ (i, 0)  0) [Suc 0..<m]
     in reduce_below_abs 0 non_zero_positions D (if A $$ (0, 0)  0 then A else 
  let i = non_zero_positions ! 0 in swaprows 0 i A))" 
    using assms True by auto
  also have "... =  reduce_below_abs 0 ?nz D (if A $$ (0, 0)  0 then A 
  else let i = ?nz ! 0 in swaprows 0 i A)" unfolding Let_def by auto
  also have "...  carrier_mat m n" using A by auto
  finally show ?thesis .  
next
  case False
  let ?nz = "(filter (λi. A $$ (i, 0)  0) [1..<m])"
  have "FindPreHNF abs_flag D A =  (let non_zero_positions = filter (λi. A $$ (i, 0)  0) [Suc 0..<m]
     in reduce_below 0 non_zero_positions D (if A $$ (0, 0)  0 then A else 
  let i = non_zero_positions ! 0 in swaprows 0 i A))" 
    using assms False by auto
  also have "... =  reduce_below 0 ?nz D (if A $$ (0, 0)  0 then A 
  else let i = ?nz ! 0 in swaprows 0 i A)" unfolding Let_def by auto
  also have "...  carrier_mat m n" using A by auto
  finally show ?thesis .
qed
  

lemma FindPreHNF_mxn2:
 assumes A: "A  carrier_mat m n" and m: "m2" and n: "n2"
 shows "FindPreHNF abs_flag D A  carrier_mat m n" 
using assms
proof (induct abs_flag D A arbitrary: m n rule: FindPreHNF.induct)
  case (1 abs_flag D A)
  note A = "1.prems"(1)
  note m = "1.prems"(2)
  note n = "1.prems"(3)
  define non_zero_positions where "non_zero_positions = filter (λi. A $$ (i,0)  0) [1..<dim_row A]"
  define A' where "A' = (if A $$ (0, 0)  0 then A else let i = non_zero_positions ! 0 in swaprows 0 i A)"
  define Reduce where [simp]: "Reduce = (if abs_flag then reduce_below_abs else reduce_below)"
  obtain A'_UL A'_UR A'_DL A'_DR where A'_split: "(A'_UL, A'_UR, A'_DL, A'_DR) 
    = split_block (Reduce 0 non_zero_positions D (make_first_column_positive A')) 1 1"     
    by (metis prod_cases4)
  define sub_PreHNF where "sub_PreHNF = FindPreHNF abs_flag D A'_DR"
  have A': "A'  carrier_mat m n" unfolding A'_def using A by auto
  have A'_DR: "A'_DR  carrier_mat (m -1) (n-1)"
    by (cases abs_flag; rule split_block(4)[OF A'_split[symmetric]], insert Reduce_def A A' m n, auto)
  have sub_PreHNF: "sub_PreHNF  carrier_mat (m - 1) (n-1)"
  proof (cases "m-1<2")
    case True
    show ?thesis using A'_DR True unfolding sub_PreHNF_def by auto
  next
    case False note m' = False
    show ?thesis
    proof (cases "n-1<2")
      case True
      show ?thesis 
        unfolding sub_PreHNF_def by (rule FindPreHNF_mx1[OF A'_DR _ _ True], insert n m', auto)
    next
      case False
      show ?thesis
        by (unfold sub_PreHNF_def, rule "1.hyps"
            [of m n, OF _ _ _ non_zero_positions_def A'_def Reduce_def _ A'_split _ _ _ A'_DR],
            insert A False n m' Reduce_def, auto)
    qed  
  qed      
  have A'_UL: "A'_UL  carrier_mat 1 1"
    by (cases abs_flag; rule split_block(1)[OF A'_split[symmetric], of "m-1" "n-1"], insert n m A', auto) 
  have A'_UR: "A'_UR  carrier_mat 1 (n-1)"
    by (cases abs_flag; rule split_block(2)[OF A'_split[symmetric], of "m-1"], insert n m A', auto)
  have A'_DL: "A'_DL  carrier_mat (m - 1) 1"
     by (cases abs_flag; rule split_block(3)[OF A'_split[symmetric], of _ "n-1"], insert n m A', auto)
  have *: "(dim_col A = 0) = False" using 1(2-) by auto
  have FindPreHNF_as_fbm: "FindPreHNF abs_flag D A = four_block_mat A'_UL A'_UR A'_DL sub_PreHNF" 
    unfolding FindPreHNF.simps[of abs_flag D A] using A'_split m n A
    unfolding Let_def sub_PreHNF_def  A'_def non_zero_positions_def * 
    apply (cases abs_flag)
    by (smt (z3) Reduce_def carrier_matD(1) carrier_matD(2) linorder_not_less prod.simps(2))+
  also have "...  carrier_mat m n"
    by (smt m A'_UL One_nat_def add.commute carrier_matD carrier_mat_triv index_mat_four_block(2,3) 
        le_add_diff_inverse2 le_eq_less_or_eq lessI n nat_SN.compat numerals(2) sub_PreHNF)  
  finally show ?case .
qed


lemma FindPreHNF:
 assumes A: "A  carrier_mat m n"
 shows "FindPreHNF abs_flag D A  carrier_mat m n" 
  using assms FindPreHNF_mxn2[OF A] FindPreHNF_mx1[OF A] FindPreHNF_1xn[OF A]
  using linorder_not_less by blast
end

lemma make_first_column_positive_append_id:
 assumes A': "A'  carrier_mat m n"
    and A_def: "A = A' @r (D m (1m n))"
  and D0: "D>0"
  and n0: "0<n"
  shows "make_first_column_positive A 
  = mat_of_rows n (map (Matrix.row (make_first_column_positive A)) [0..<m]) @r (D m (1m n))"
proof (rule matrix_append_rows_eq_if_preserves)
  have A: "A  carrier_mat (m+n) n" using A' A_def by auto
  thus "make_first_column_positive A  carrier_mat (m + n) n" by auto
  have "make_first_column_positive A $$ (i, j) = (D m 1m n) $$ (i - m, j)"
    if j: "j<n" and i: "i  {m..<m + n}" for i j
  proof -
    have i_mn: "i<m+n" using i by auto
    have "A $$ (i,0) = (D m 1m n) $$ (i - m, 0)" unfolding A_def
      by (smt A append_rows_def assms(1) assms(2) atLeastLessThan_iff carrier_matD 
          index_mat_four_block less_irrefl_nat nat_SN.compat j i n0)
    also have "...  0" using D0 mult_not_zero that(2) by auto
    finally have Ai0: "A$$(i,0)0" .
    have "make_first_column_positive A $$ (i, j) = A$$(i,j)"
      using make_first_column_positive_works[OF A i_mn n0] j Ai0 by auto
    also have "... = (D m 1m n) $$ (i - m, j)" unfolding A_def
      by (smt A append_rows_def A' A_def atLeastLessThan_iff carrier_matD 
          index_mat_four_block less_irrefl_nat nat_SN.compat i j)
    finally show ?thesis .
  qed
  thus "i{m..<m + n}. j<n. make_first_column_positive A $$ (i, j) = (D m 1m n) $$ (i - m, j)"
    by simp
qed (auto)


lemma A'_swaprows_invertible_mat:
  fixes A::"int mat"
  assumes A: "Acarrier_mat m n"
  assumes A'_def: "A' = (if A $$ (0, 0)  0 then A else let i = non_zero_positions ! 0 in swaprows 0 i A)"
  and nz_def: "non_zero_positions = filter (λi. A $$ (i,0)  0) [1..<dim_row A]"
  and nz_empty: "A$$(0,0) =0  non_zero_positions  []"
  and m0: "0<m"
shows "P. P  carrier_mat m m  invertible_mat P  A' = P * A"
proof (cases "A$$(0,0)  0")
  case True
  then show ?thesis
    by (metis A A'_def invertible_mat_one left_mult_one_mat one_carrier_mat)
next
  case False
  have nz_empty: "non_zero_positions  []" using nz_empty False by simp
  let ?i = "non_zero_positions ! 0"
  let ?M = "(swaprows_mat m 0 ?i) :: int mat"
  have i_set_nz: "?i  set (non_zero_positions)" using nz_empty by auto
  have im: "?i < m" using A nz_def i_set_nz by auto
  have i_not0: "?i  0" using A nz_def i_set_nz by auto
  have "A' = swaprows 0 ?i A" using False A'_def by simp
  also have "... = ?M * A"
    by (rule swaprows_mat[OF A], insert nz_def nz_empty False A m0 im, auto) 
  finally have 1: "A' = ?M * A" .
  have 2: "?M  carrier_mat m m" by auto
  have "Determinant.det ?M = - 1"
    by (rule det_swaprows_mat[OF m0 im i_not0[symmetric]])
  hence 3: "invertible_mat ?M" using invertible_iff_is_unit_JNF[OF 2] by auto  
  show ?thesis using 1 2 3 by blast
qed

lemma swaprows_append_id:
 assumes A': "A'  carrier_mat m n"
    and A_def: "A = A' @r (D m (1m n))"
  and i:"i<m"
  shows "swaprows 0 i A 
  = mat_of_rows n (map (Matrix.row (swaprows 0 i A)) [0..<m]) @r (D m (1m n))"
proof (rule matrix_append_rows_eq_if_preserves)
  have A: "A  carrier_mat (m+n) n" using A' A_def by auto
  show swap: "swaprows 0 i A  carrier_mat (m + n) n" by (simp add: A)
  have "swaprows 0 i A $$ (ia, j) = (D m 1m n) $$ (ia - m, j)"
    if ia: "ia  {m..<m + n}" and j: "j<n" for ia j
  proof -
    have "swaprows 0 i A $$ (ia, j) = A $$ (ia,j)" using i ia j A by auto
    also have "... = (D m 1m n) $$ (ia - m, j)" 
      by (smt A append_rows_def A' A_def atLeastLessThan_iff carrier_matD 
          index_mat_four_block less_irrefl_nat nat_SN.compat ia j)
    finally show "swaprows 0 i A $$ (ia, j) = (D m 1m n) $$ (ia - m, j)" .
  qed
  thus "ia{m..<m + n}. j<n. swaprows 0 i A $$ (ia, j) = (D m 1m n) $$ (ia - m, j)" by simp
qed (simp)



lemma non_zero_positions_xs_m:
  fixes A::"'a::comm_ring_1 mat"
  assumes A_def: "A = A' @r D m 1m n"
  and A': "A'  carrier_mat m n" 
  and nz_def: "non_zero_positions = filter (λi. A $$ (i,0)  0) [1..<dim_row A]"
  and m0: "0<m" and n0: "0<n"
  and D0: "D  0"
shows "xs. non_zero_positions = xs @ [m]  distinct xs  (xset xs. x < m  0 < x)"
proof -  
  have A: "A  carrier_mat (m+n) n" using A' A_def by auto
  let ?xs = "filter (λi. A $$ (i,0)  0) [1..<m]"
  have l_rw: "[1..<dim_row A] = [1..<m+1]@[m+1..<dim_row A]" using A m0 n0
    by (auto, metis Suc_leI less_add_same_cancel1 upt_add_eq_append upt_conv_Cons)
  have f0: "filter (λi. A $$ (i,0)  0) ([m+1..<dim_row A]) = []"
  proof (rule filter_False) 
    have "A $$ (i,0) = 0" if i: "iset [m + 1..<dim_row A]" for i
    proof -
      have "A $$ (i,0) = (D m 1m n) $$ (i-m,0)"
        by (rule append_rows_nth3[OF A' _ A_def _ _ n0], insert i A, auto)
      also have "... = 0" using i A by auto
      finally show ?thesis .        
    qed
    thus "xset [m + 1..<dim_row A]. ¬ A $$ (x, 0)  0" by blast
  qed
  have fm: "filter (λi. A $$ (i,0)  0) [m] = [m]"
  proof -
    have "A $$ (m, 0) = (D m 1m n) $$ (m-m,0)"
      by (rule append_rows_nth3[OF A' _ A_def _ _ n0], insert n0, auto)
    also have "... = D" using m0 n0 by auto
    finally show ?thesis using D0 by auto
  qed
  have "non_zero_positions = filter (λi. A $$ (i,0)  0) ([1..<m+1]@[m+1..<dim_row A])"
    using nz_def l_rw by auto
  also have "... = filter (λi. A $$ (i,0)  0) [1..<m+1] @ filter (λi. A $$ (i,0)  0) ([m+1..<dim_row A])"
    by auto
  also have "... = filter (λi. A $$ (i,0)  0) [1..<m+1]" using f0 by auto
  also have "... = filter (λi. A $$ (i,0)  0) ([1..<m]@[m])" using m0 by auto
  also have "... = filter (λi. A $$ (i,0)  0) [1..<m] @ [m]" using fm by auto
  finally have "non_zero_positions = ?xs @ [m]" .
  moreover have "distinct ?xs" by auto
  moreover have "(xset ?xs. x < m  0 < x)" by auto
  ultimately show ?thesis by blast
qed




lemma non_zero_positions_xs_m':
  fixes A::"'a::comm_ring_1 mat"
  assumes A_def: "A = A' @r D m 1m n"
  and A': "A'  carrier_mat m n" 
  and nz_def: "non_zero_positions = filter (λi. A $$ (i,0)  0) [1..<dim_row A]"
  and m0: "0<m" and n0: "0<n"
  and D0: "D  0"
shows "non_zero_positions = (filter (λi. A $$ (i,0)  0) [1..<m]) @ [m] 
   distinct (filter (λi. A $$ (i,0)  0) [1..<m]) 
   (xset (filter (λi. A $$ (i,0)  0) [1..<m]). x < m  0 < x)"
proof -  
  have A: "A  carrier_mat (m+n) n" using A' A_def by auto
  let ?xs = "filter (λi. A $$ (i,0)  0) [1..<m]"
  have l_rw: "[1..<dim_row A] = [1..<m+1]@[m+1..<dim_row A]" using A m0 n0
    by (auto, metis Suc_leI less_add_same_cancel1 upt_add_eq_append upt_conv_Cons)
  have f0: "filter (λi. A $$ (i,0)  0) ([m+1..<dim_row A]) = []"
  proof (rule filter_False) 
    have "A $$ (i,0) = 0" if i: "iset [m + 1..<dim_row A]" for i
    proof -
      have "A $$ (i,0) = (D m 1m n) $$ (i-m,0)"
        by (rule append_rows_nth3[OF A' _ A_def _ _ n0], insert i A, auto)
      also have "... = 0" using i A by auto
      finally show ?thesis .        
    qed
    thus "xset [m + 1..<dim_row A]. ¬ A $$ (x, 0)  0" by blast
  qed
  have fm: "filter (λi. A $$ (i,0)  0) [m] = [m]"
  proof -
    have "A $$ (m, 0) = (D m 1m n) $$ (m-m,0)"
      by (rule append_rows_nth3[OF A' _ A_def _ _ n0], insert n0, auto)
    also have "... = D" using m0 n0 by auto
    finally show ?thesis using D0 by auto
  qed
  have "non_zero_positions = filter (λi. A $$ (i,0)  0) ([1..<m+1]@[m+1..<dim_row A])"
    using nz_def l_rw by auto
  also have "... = filter (λi. A $$ (i,0)  0) [1..<m+1] @ filter (λi. A $$ (i,0)  0) ([m+1..<dim_row A])"
    by auto
  also have "... = filter (λi. A $$ (i,0)  0) [1..<m+1]" using f0 by auto
  also have "... = filter (λi. A $$ (i,0)  0) ([1..<m]@[m])" using m0 by auto
  also have "... = filter (λi. A $$ (i,0)  0) [1..<m] @ [m]" using fm by auto
  finally have "non_zero_positions = ?xs @ [m]" .
  moreover have "distinct ?xs" by auto
  moreover have "(xset ?xs. x < m  0 < x)" by auto
  ultimately show ?thesis by blast
qed

lemma A_A'D_eq_first_n_rows:
 assumes A_def: "A = A' @r D m 1m n"
  and A': "A'  carrier_mat m n" 
  and mn: "mn"
shows "(mat_of_rows n (map (Matrix.row A') [0..<n])) 
  = (mat_of_rows n (map (Matrix.row A) [0..<n]))" (is "?lhs = ?rhs")
proof (rule eq_matI) 
  show dr: "dim_row ?lhs = dim_row ?rhs" and dc: "dim_col ?lhs = dim_col ?rhs" by auto
  have D: "D m 1m n : carrier_mat n n" by simp
  fix i j assume i: "i<dim_row ?rhs" and j: "j<dim_col ?rhs"
  have "?lhs $$ (i,j) = A' $$ (i,j)" using i j dr dc A' mn by (simp add: mat_of_rows_def)
  also have "... = A $$ (i,j)" using append_rows_nth[OF A' D] i j dr dc A' mn A_def by auto
  also have "... = ?rhs $$ (i,j)" using i j dr dc A' A_def mn
    by (metis D calculation carrier_matD(1) diff_zero gr_implies_not0 length_map length_upt 
        linordered_semidom_class.add_diff_inverse mat_of_rows_carrier(2,3)
        mat_of_rows_index nat_SN.compat nth_map_upt row_append_rows1)
  finally show "?lhs $$ (i,j) = ?rhs $$ (i,j)" .
qed

lemma non_zero_positions_xs_m_invertible:  
  assumes A_def: "A = A' @r D m 1m n"
  and A': "A'  carrier_mat m n" 
  and nz_def: "non_zero_positions = filter (λi. A $$ (i,0)  0) [1..<dim_row A]"
  and m0: "0<m" and n0: "0<n"
  and D0: "D  0"
  and inv_A'': "invertible_mat (map_mat rat_of_int (mat_of_rows n (map (Matrix.row A') [0..<n])))"
  and A'00: "A' $$ (0,0) = 0"
  and mn: "mn"
shows "length non_zero_positions > 1"
proof -  
  have A: "A  carrier_mat (m+n) n" using A' A_def by auto
  have D: "D m 1m n : carrier_mat n n" by auto
  let ?RAT = "map_mat rat_of_int"
  let ?A'' = "(mat_of_rows n (map (Matrix.row A') [0..<n]))"
  have A'': "?A''  carrier_mat n n" by auto
  have RAT_A'': "?RAT ?A''  carrier_mat n n" by auto
  let ?ys = "filter (λi. A $$ (i,0)  0) [1..<m]"
  let ?xs = "filter (λi. A $$ (i,0)  0) [1..<n]"
  have xs_not_empty:"?xs  []"
  proof (rule ccontr)
    assume "¬ ?xs  []" hence xs0: "?xs = []" by simp
    have A00: "A $$ (0,0) = 0" 
    proof -
      have "A $$ (0,0) = A'$$(0,0)" unfolding A_def using append_rows_nth[OF A' D] m0 n0 A' by auto
      thus ?thesis using A'00 by simp
    qed
    hence "(iset [1..<n]. A $$ (i,0) = 0)"
      by (metis (mono_tags, lifting) empty_filter_conv xs0)
    hence *: "(i<n. A $$ (i,0) = 0)" using A00 n0 using linorder_not_less by force
    have "col ?A'' 0 = 0v n"
    proof (rule eq_vecI)
      show "dim_vec (col ?A'' 0) = dim_vec (0vn)" using A' by auto
      fix i assume i: "i < dim_vec (0v n)" 
      have "col ?A'' 0 $v i = ?A'' $$ (i,0)" by (rule index_col, insert i A' n0, auto)
      also have "... = A $$ (i,0)" 
        unfolding A_def using i A append_rows_nth[OF A' D _ n0] A' mn 
        by (metis A'' n0 carrier_matD(1) index_zero_vec(2) le_add2 map_first_rows_index
            mat_of_rows_carrier(2) mat_of_rows_index nat_SN.compat)
      also have "... = 0" using * i by auto
      finally show "col ?A'' 0 $v i = 0v n $v i" using i by auto
    qed
    hence "col (?RAT ?A'') 0 = 0v n" by auto
    hence "¬ invertible_mat (?RAT ?A'')"
      using invertible_mat_first_column_not0[OF RAT_A'' _ n0] by auto
    thus False using inv_A'' by contradiction
  qed
  have l_rw: "[1..<dim_row A] = [1..<m+1]@[m+1..<dim_row A]" using A m0 n0
    by (auto, metis Suc_leI less_add_same_cancel1 upt_add_eq_append upt_conv_Cons)
  have f0: "filter (λi. A $$ (i,0)  0) ([m+1..<dim_row A]) = []"
  proof (rule filter_False) 
    have "A $$ (i,0) = 0" if i: "iset [m + 1..<dim_row A]" for i
    proof -
      have "A $$ (i,0) = (D m 1m n) $$ (i-m,0)"
        by (rule append_rows_nth3[OF A' _ A_def _ _ n0], insert i A, auto)
      also have "... = 0" using i A by auto
      finally show ?thesis .        
    qed
    thus "xset [m + 1..<dim_row A]. ¬ A $$ (x, 0)  0" by blast
  qed
  have fm: "filter (λi. A $$ (i,0)  0) [m] = [m]"
  proof -
    have "A $$ (m, 0) = (D m 1m n) $$ (m-m,0)"
      by (rule append_rows_nth3[OF A' _ A_def _ _ n0], insert n0, auto)
    also have "... = D" using m0 n0 by auto
    finally show ?thesis using D0 by auto
  qed
  have "non_zero_positions = filter (λi. A $$ (i,0)  0) ([1..<m+1]@[m+1..<dim_row A])"
    using nz_def l_rw by auto
  also have "... = filter (λi. A $$ (i,0)  0) [1..<m+1] @ filter (λi. A $$ (i,0)  0) ([m+1..<dim_row A])"
    by auto
  also have "... = filter (λi. A $$ (i,0)  0) [1..<m+1]" using f0 by auto
  also have "... = filter (λi. A $$ (i,0)  0) ([1..<m]@[m])" using m0 by auto
  also have "... = filter (λi. A $$ (i,0)  0) [1..<m] @ [m]" using fm by auto
  finally have nz: "non_zero_positions = ?ys @ [m]" .
  moreover have ys_not_empty: "?ys  []" using xs_not_empty mn
    by (metis (no_types, lifting) atLeastLessThan_iff empty_filter_conv nat_SN.compat set_upt)
  show ?thesis unfolding nz using ys_not_empty by auto  
qed



corollary non_zero_positions_length_xs:  
  assumes A_def: "A = A' @r D m 1m n"
  and A': "A'  carrier_mat m n" 
  and nz_def: "non_zero_positions = filter (λi. A $$ (i,0)  0) [1..<dim_row A]"
  and m0: "0<m" and n0: "0<n"
  and D0: "D  0"
  and inv_A'': "invertible_mat (map_mat rat_of_int (mat_of_rows n (map (Matrix.row A') [0..<n])))"
  and A'00: "A' $$ (0,0) = 0"
  and mn: "mn"
  and nz_xs_m: "non_zero_positions = xs @ [m]"
shows "length xs > 0"
proof -  
  have "length non_zero_positions > 1" 
    by (rule non_zero_positions_xs_m_invertible[OF A_def A' nz_def m0 n0 D0 inv_A'' A'00 mn])
  thus ?thesis using nz_xs_m by auto  
qed



lemma make_first_column_positive_nz_conv:
  assumes "i<dim_row A" and "j<dim_col A"
  shows "(make_first_column_positive A $$ (i, j)  0) = (A $$ (i, j)  0)"
  using assms unfolding make_first_column_positive.simps by auto



lemma make_first_column_positive_00:
  assumes A_def: "A = A'' @r D m 1m n"
    and A'': "A'' : carrier_mat m n"
  assumes nz_def: "non_zero_positions = filter (λi. A $$ (i,0)  0) [1..<dim_row A]"
    and A'_def: "A' = (if A $$ (0, 0)  0 then A else let i = non_zero_positions ! 0 in swaprows 0 i A)"
    and m0: "0<m" and n0: "0<n" and D0: "D  0" and mn: "mn"
  shows "make_first_column_positive A' $$ (0, 0)  0"
proof -
  have A: "A  carrier_mat (m+n) n" using A_def A'' by auto
  hence A': "A'  carrier_mat (m+n) n" unfolding A'_def by auto 
  have "(make_first_column_positive A' $$ (0, 0)  0) = (A' $$ (0, 0)  0)"
    by (rule make_first_column_positive_nz_conv, insert m0 n0 A', auto)
  moreover have "A' $$ (0, 0)  0"
  proof (cases "A $$ (0, 0)  0")
    case True
    then show ?thesis unfolding A'_def by auto
  next
    case False
    have "A $$ (0, 0) = A'' $$ (0, 0)"
      by (smt add_gr_0 append_rows_def A_def A'' carrier_matD index_mat_four_block(1) mn n0 nat_SN.compat)
    hence A''00: "A''$$(0,0) = 0" using False by auto
    let ?i = "non_zero_positions ! 0"
    obtain xs where non_zero_positions_xs_m: "non_zero_positions = xs @ [m]" and d_xs: "distinct xs"
      and all_less_m: "xset xs. x < m  0 < x" 
      using non_zero_positions_xs_m[OF A_def A'' nz_def m0 n0] using D0 by fast    
    have Ai0:"A $$ (?i,0)  0"
      by (smt append.simps(1) append_Cons append_same_eq nz_def in_set_conv_nth length_greater_0_conv
          list.simps(3) local.non_zero_positions_xs_m mem_Collect_eq set_filter)  
    have "A' $$ (0, 0) = swaprows 0 ?i A $$ (0,0)"  using False A'_def by auto
    also have "...  0" using A Ai0 n0 by auto  
    finally show ?thesis .
  qed
  ultimately show ?thesis by blast
qed


context proper_mod_operation
begin
lemma reduce_below_0_case_m_make_first_column_positive:
  assumes A': "A'  carrier_mat m n" and m0: "0<m" and n0: "0<n"
    and A_def: "A = A' @r (D m (1m n))"
    and mn: "mn"
  assumes i_mn: "i < m+n" and d_xs: "distinct xs" and xs: "x  set xs. x < m  0 < x"
    and ia: "i0"
    and A''_def: "A'' = (if A $$ (0, 0)  0 then A else let i = non_zero_positions ! 0 in swaprows 0 i A)"
    and D0: "D>0"
    and nz_def: "non_zero_positions = filter (λi. A $$ (i,0)  0) [1..<dim_row A]"
  shows "reduce_below 0 non_zero_positions D (make_first_column_positive A'') $$ (i,0) = 0"
proof -
  have A: "A  carrier_mat (m+n) n" using A' A_def by auto
  define xs where "xs = filter (λi. A $$ (i,0)  0) [1..<m]"
  have nz_xs_m: "non_zero_positions = xs @ [m]" and d_xs: "distinct xs"
    and all_less_m: "xset xs. x < m  0 < x" 
    using non_zero_positions_xs_m'[OF A_def A' nz_def m0 n0] using D0 A unfolding nz_def xs_def by auto
  have A'': "A''  carrier_mat (m+n) n" using A' A_def A''_def by auto
  have D_not0: "D0" using D0 by auto
  have Ai0: "A $$ (i, 0) = 0" if im: "i>m" and imn: "i<m+n" for i
  proof-
    have D: "(D m (1m n))  carrier_mat n n" by simp
    have "A $$ (i, 0) = (D m (1m n)) $$ (i-m, 0)"
      unfolding A_def using append_rows_nth[OF A' D imn n0] im A' by auto 
    also have "... = 0" using im imn n0 by auto
    finally show ?thesis .
  qed
  let ?M' = "mat_of_rows n (map (Matrix.row (make_first_column_positive A'')) [0..<m])"
  have M': "?M'  carrier_mat m n" using A'' by auto
  have mk0: "make_first_column_positive A'' $$ (0, 0)  0"
    by (rule make_first_column_positive_00[OF A_def A' nz_def A''_def m0 n0 D_not0 mn])
  have M_M'D: "make_first_column_positive A'' = ?M' @r D m 1m n" if xs_empty: "xs  []"
  proof (cases "A$$(0,0)  0")
    case True
    then have *: "make_first_column_positive A'' = make_first_column_positive A"
      unfolding A''_def by auto        
    show ?thesis 
      by (unfold *, rule make_first_column_positive_append_id[OF A' A_def D0 n0])
  next
    case False
    then have *: "make_first_column_positive A'' 
                  = make_first_column_positive (swaprows 0 (non_zero_positions ! 0) A)"
      unfolding A''_def by auto
    show ?thesis
    proof (unfold *, rule make_first_column_positive_append_id)
      let ?S = "mat_of_rows n (map (Matrix.row (swaprows 0 (non_zero_positions ! 0) A)) [0..<m])"
      show "swaprows 0 (non_zero_positions ! 0) A =  ?S @r (D m (1m n))"
      proof (rule swaprows_append_id[OF A' A_def])
        have A'00: "A' $$ (0, 0) = 0"          
          by (metis (no_types, lifting) A False add_pos_pos append_rows_def A' A_def 
              carrier_matD index_mat_four_block m0 n0)
        have length_xs: "length xs > 0" using xs_empty by auto
        have "non_zero_positions ! 0 = xs ! 0" unfolding nz_xs_m
          by (meson length_xs nth_append)
        thus "non_zero_positions ! 0 < m" using all_less_m length_xs by simp
      qed
    qed (insert n0 D0, auto)            
  qed
  show ?thesis
  proof (cases "xs = []")
    case True note xs_empty = True
    have "reduce_below 0 non_zero_positions D (make_first_column_positive A'') 
      = reduce 0 m D (make_first_column_positive A'')"
      unfolding nz_xs_m True by auto

    also have "...  $$ (i, 0) = 0"
    proof (cases "i=m")
      case True
      from D0 have "D  1" "D  0" by auto
      then show ?thesis using D0 True
        by (metis A add_sign_intros(2) A''_def carrier_matD(1) carrier_matD(2) carrier_matI 
            index_mat_swaprows(2) index_mat_swaprows(3) less_add_same_cancel1 m0 
            make_first_column_positive_preserves_dimensions mk0 n0 neq0_conv reduce_0)
    next
      case False note i_not_m = False
      have nz_m: "non_zero_positions ! 0 = m" unfolding nz_xs_m True by auto
      let ?M = "make_first_column_positive A''"
      have M: "?M  carrier_mat (m+n) n" using A'' by auto
      show ?thesis
      proof (cases "A$$(0,0) = 0")
        case True
        have "reduce 0 m D ?M $$ (i, 0) = ?M $$ (i,0)" 
          by (rule reduce_preserves[OF M n0 mk0 False ia i_mn])
        also have Mi0: "... = abs (A'' $$ (i,0))"
          by (smt M carrier_matD(1) carrier_matD(2) i_mn index_mat(1) make_first_column_positive.simps
              make_first_column_positive_preserves_dimensions n0 prod.simps(2))
        also have Mi02: "... = abs (A $$ (i,0)) " unfolding A''_def nz_m
          using True A False i_mn ia n0 by auto
        also have "... = 0"
        proof -
          have "filter (λn. A $$ (n, 0)  0) [1..<m] = []"
            using xs_empty xs_def by presburger
          then have "n. A $$ (n, 0) = 0  n  set [1..<m]" using filter_empty_conv by fast          
          then show ?thesis
            by (metis (no_types) Ai0 False arith_simps(43) assms(9) atLeastLessThan_iff i_mn
                le_eq_less_or_eq less_one linorder_neqE_nat set_upt)
        qed
        finally show ?thesis .
      next
        case False hence A00: "A $$ (0,0)  0" by simp
        have "reduce 0 m D ?M $$ (i, 0) = ?M $$ (i,0)" 
          by (rule reduce_preserves[OF M n0 mk0 i_not_m ia i_mn])
        also have Mi0: "... = abs (A'' $$ (i,0))"
          by (smt M carrier_matD(1) carrier_matD(2) i_mn index_mat(1) make_first_column_positive.simps
              make_first_column_positive_preserves_dimensions n0 prod.simps(2))
        also have Mi02: "... = abs (swaprows 0 m A $$ (i,0)) " unfolding A''_def nz_m
          using A00 A i_not_m i_mn ia n0 by auto
        also have "... = abs (A $$ (i,0))" using False ia A00 Mi0 A''_def calculation Mi02 by presburger  
        also have "... = 0"
        proof -
          have "filter (λn. A $$ (n, 0)  0) [1..<m] = []"
            using True xs_def by presburger
          then have "n. A $$ (n, 0) = 0  n  set [1..<m]" using filter_empty_conv by fast          
          then show ?thesis
            by (metis (no_types) Ai0 i_not_m arith_simps(43) ia atLeastLessThan_iff i_mn
                le_eq_less_or_eq less_one linorder_neqE_nat set_upt)
        qed
        finally show ?thesis .
      qed
    qed
    finally show ?thesis .
  next
    case False note xs_not_empty = False
    note M_M'D = M_M'D[OF xs_not_empty]
    show ?thesis   
    proof (cases "i  set (xs @ [m])")
      case True
      show ?thesis  
        by (unfold nz_xs_m, rule reduce_below_0_case_m[OF M' m0 n0 M_M'D mk0 mn True d_xs all_less_m D0])
    next
      case False note i_notin_xs_m = False
      have 1: "reduce_below 0 (xs @ [m]) D (make_first_column_positive A'') $$ (i,0) 
        = (make_first_column_positive A'') $$ (i,0)"    
        by (rule reduce_below_preserves_case_m[OF M' m0 n0 M_M'D mk0 mn _ d_xs all_less_m ia i_mn _ D0],
            insert False, auto) 
      have "((make_first_column_positive A'') $$ (i,0)  0) = (A'' $$ (i,0)  0)"
        by (rule make_first_column_positive_nz_conv, insert A'' i_mn n0, auto)
      hence 2: "((make_first_column_positive A'') $$ (i,0) = 0) = (A'' $$ (i,0) = 0)" by auto
      have 3: "(A'' $$ (i,0) = 0)"
      proof (cases "A$$(0,0)  0")
        case True
        then have "A'' $$ (i, 0) = A $$ (i, 0)" unfolding A''_def by auto
        also have "... = 0" using False ia i_mn A nz_xs_m Ai0 unfolding nz_def xs_def by auto
        finally show ?thesis by auto
      next
        case False hence A00: "A $$ (0,0) = 0" by simp
        let ?i = "non_zero_positions ! 0"
        have i_noti: "i?i" 
          using i_notin_xs_m unfolding nz_xs_m
          by (metis Nil_is_append_conv length_greater_0_conv list.distinct(2) nth_mem)
        have "A''$$(i,0) = (swaprows 0 ?i A) $$ (i,0)" using False unfolding A''_def by auto
        also have "... = A $$ (i,0)" using i_notin_xs_m ia i_mn A i_noti n0 unfolding xs_def by fastforce  
        also have "... = 0" using i_notin_xs_m ia i_mn A i_noti n0 unfolding xs_def 
          by (smt nz_def atLeastLessThan_iff carrier_matD(1) less_one linorder_not_less
              mem_Collect_eq nz_xs_m set_filter set_upt xs_def) 
        finally show ?thesis .
      qed
      show ?thesis using 1 2 3 nz_xs_m by argo
    qed
  qed
qed


lemma reduce_below_abs_0_case_m_make_first_column_positive:
  assumes A': "A'  carrier_mat m n" and m0: "0<m" and n0: "0<n"
    and A_def: "A = A' @r (D m (1m n))"
    and mn: "mn"
  assumes i_mn: "i < m+n" and d_xs: "distinct xs" and xs: "x  set xs. x < m  0 < x"
    and ia: "i0"
    and A''_def: "A'' = (if A $$ (0, 0)  0 then A else let i = non_zero_positions ! 0 in swaprows 0 i A)"
    and D0: "D>0"
    and nz_def: "non_zero_positions = filter (λi. A $$ (i,0)  0) [1..<dim_row A]"
  shows "reduce_below_abs 0 non_zero_positions D (make_first_column_positive A'') $$ (i,0) = 0"
proof -
  have A: "A  carrier_mat (m+n) n" using A' A_def by auto
  define xs where "xs = filter (λi. A $$ (i,0)  0) [1..<m]"
  have nz_xs_m: "non_zero_positions = xs @ [m]" and d_xs: "distinct xs"
    and all_less_m: "xset xs. x < m  0 < x" 
    using non_zero_positions_xs_m'[OF A_def A' nz_def m0 n0] using D0 A unfolding nz_def xs_def by auto
  have A'': "A''  carrier_mat (m+n) n" using A' A_def A''_def by auto
  have D_not0: "D0" using D0 by auto
  have Ai0: "A $$ (i, 0) = 0" if im: "i>m" and imn: "i<m+n" for i
  proof-
    have D: "(D m (1m n))  carrier_mat n n" by simp
    have "A $$ (i, 0) = (D m (1m n)) $$ (i-m, 0)"
      unfolding A_def using append_rows_nth[OF A' D imn n0] im A' by auto 
    also have "... = 0" using im imn n0 by auto
    finally show ?thesis .
  qed
  let ?M' = "mat_of_rows n (map (Matrix.row (make_first_column_positive A'')) [0..<m])"
  have M': "?M'  carrier_mat m n" using A'' by auto
  have mk0: "make_first_column_positive A'' $$ (0, 0)  0"
    by (rule make_first_column_positive_00[OF A_def A' nz_def A''_def m0 n0 D_not0 mn])
  have M_M'D: "make_first_column_positive A'' = ?M' @r D m 1m n" if xs_empty: "xs  []"
  proof (cases "A$$(0,0)  0")
    case True
    then have *: "make_first_column_positive A'' = make_first_column_positive A"
      unfolding A''_def by auto        
    show ?thesis 
      by (unfold *, rule make_first_column_positive_append_id[OF A' A_def D0 n0])
  next
    case False
    then have *: "make_first_column_positive A'' 
                  = make_first_column_positive (swaprows 0 (non_zero_positions ! 0) A)"
      unfolding A''_def by auto
    show ?thesis
    proof (unfold *, rule make_first_column_positive_append_id)
      let ?S = "mat_of_rows n (map (Matrix.row (swaprows 0 (non_zero_positions ! 0) A)) [0..<m])"
      show "swaprows 0 (non_zero_positions ! 0) A =  ?S @r (D m (1m n))"
      proof (rule swaprows_append_id[OF A' A_def])
        have A'00: "A' $$ (0, 0) = 0"          
          by (metis (no_types, lifting) A False add_pos_pos append_rows_def A' A_def 
              carrier_matD index_mat_four_block m0 n0)
        have length_xs: "length xs > 0" using xs_empty by auto
        have "non_zero_positions ! 0 = xs ! 0" unfolding nz_xs_m
          by (meson length_xs nth_append)
        thus "non_zero_positions ! 0 < m" using all_less_m length_xs by simp
      qed
    qed (insert n0 D0, auto)            
  qed
  show ?thesis
  proof (cases "xs = []")
    case True note xs_empty = True
    have "reduce_below_abs 0 non_zero_positions D (make_first_column_positive A'') 
      = reduce_abs 0 m D (make_first_column_positive A'')"
      unfolding nz_xs_m True by auto

    also have "...  $$ (i, 0) = 0"
    proof (cases "i=m")
      case True
      from D0 have "D  1" "D  0" by auto
      then show ?thesis using D0 True
        by (metis A add_sign_intros(2) A''_def carrier_matD(1) carrier_matD(2) carrier_matI 
            index_mat_swaprows(2) index_mat_swaprows(3) less_add_same_cancel1 m0 
            make_first_column_positive_preserves_dimensions mk0 n0 neq0_conv reduce_0)
    next
      case False note i_not_m = False
      have nz_m: "non_zero_positions ! 0 = m" unfolding nz_xs_m True by auto
      let ?M = "make_first_column_positive A''"
      have M: "?M  carrier_mat (m+n) n" using A'' by auto
      show ?thesis
      proof (cases "A$$(0,0) = 0")
        case True
        have "reduce_abs 0 m D ?M $$ (i, 0) = ?M $$ (i,0)" 
          by (rule reduce_preserves[OF M n0 mk0 False ia i_mn])
        also have Mi0: "... = abs (A'' $$ (i,0))"
          by (smt M carrier_matD(1) carrier_matD(2) i_mn index_mat(1) make_first_column_positive.simps
              make_first_column_positive_preserves_dimensions n0 prod.simps(2))
        also have Mi02: "... = abs (A $$ (i,0)) " unfolding A''_def nz_m
          using True A False i_mn ia n0 by auto
        also have "... = 0"
        proof -
          have "filter (λn. A $$ (n, 0)  0) [1..<m] = []"
            using xs_empty xs_def by presburger
          then have "n. A $$ (n, 0) = 0  n  set [1..<m]" using filter_empty_conv by fast          
          then show ?thesis
            by (metis (no_types) Ai0 False arith_simps(43) assms(9) atLeastLessThan_iff i_mn
                le_eq_less_or_eq less_one linorder_neqE_nat set_upt)
        qed
        finally show ?thesis .
      next
        case False hence A00: "A $$ (0,0)  0" by simp
        have "reduce_abs 0 m D ?M $$ (i, 0) = ?M $$ (i,0)" 
          by (rule reduce_preserves[OF M n0 mk0 i_not_m ia i_mn])
        also have Mi0: "... = abs (A'' $$ (i,0))"
          by (smt M carrier_matD(1) carrier_matD(2) i_mn index_mat(1) make_first_column_positive.simps
              make_first_column_positive_preserves_dimensions n0 prod.simps(2))
        also have Mi02: "... = abs (swaprows 0 m A $$ (i,0)) " unfolding A''_def nz_m
          using A00 A i_not_m i_mn ia n0 by auto
        also have "... = abs (A $$ (i,0))" using False ia A00 Mi0 A''_def calculation Mi02 by presburger  
        also have "... = 0"
        proof -
          have "filter (λn. A $$ (n, 0)  0) [1..<m] = []"
            using True xs_def by presburger
          then have "n. A $$ (n, 0) = 0  n  set [1..<m]" using filter_empty_conv by fast          
          then show ?thesis
            by (metis (no_types) Ai0 i_not_m arith_simps(43) ia atLeastLessThan_iff i_mn
                le_eq_less_or_eq less_one linorder_neqE_nat set_upt)
        qed
        finally show ?thesis .
      qed
    qed
    finally show ?thesis .
  next
    case False note xs_not_empty = False
    note M_M'D = M_M'D[OF xs_not_empty]
    show ?thesis   
    proof (cases "i  set (xs @ [m])")
      case True
      show ?thesis  
        by (unfold nz_xs_m, rule reduce_below_abs_0_case_m[OF M' m0 n0 M_M'D mk0 mn True d_xs all_less_m D0])
    next
      case False note i_notin_xs_m = False
      have 1: "reduce_below_abs 0 (xs @ [m]) D (make_first_column_positive A'') $$ (i,0) 
        = (make_first_column_positive A'') $$ (i,0)"    
        by (rule reduce_below_abs_preserves_case_m[OF M' m0 n0 M_M'D mk0 mn _ d_xs all_less_m ia i_mn _ D0],
            insert False, auto) 
      have "((make_first_column_positive A'') $$ (i,0)  0) = (A'' $$ (i,0)  0)"
        by (rule make_first_column_positive_nz_conv, insert A'' i_mn n0, auto)
      hence 2: "((make_first_column_positive A'') $$ (i,0) = 0) = (A'' $$ (i,0) = 0)" by auto
      have 3: "(A'' $$ (i,0) = 0)"
      proof (cases "A$$(0,0)  0")
        case True
        then have "A'' $$ (i, 0) = A $$ (i, 0)" unfolding A''_def by auto
        also have "... = 0" using False ia i_mn A nz_xs_m Ai0 unfolding nz_def xs_def by auto
        finally show ?thesis by auto
      next
        case False hence A00: "A $$ (0,0) = 0" by simp
        let ?i = "non_zero_positions ! 0"
        have i_noti: "i?i" 
          using i_notin_xs_m unfolding nz_xs_m
          by (metis Nil_is_append_conv length_greater_0_conv list.distinct(2) nth_mem)
        have "A''$$(i,0) = (swaprows 0 ?i A) $$ (i,0)" using False unfolding A''_def by auto
        also have "... = A $$ (i,0)" using i_notin_xs_m ia i_mn A i_noti n0 unfolding xs_def by fastforce  
        also have "... = 0" using i_notin_xs_m ia i_mn A i_noti n0 unfolding xs_def 
          by (smt nz_def atLeastLessThan_iff carrier_matD(1) less_one linorder_not_less
              mem_Collect_eq nz_xs_m set_filter set_upt xs_def) 
        finally show ?thesis .
      qed
      show ?thesis using 1 2 3 nz_xs_m by argo
    qed
  qed
qed


lemma FindPreHNF_invertible_mat_2xn:
  assumes A: "A  carrier_mat m n" and "m<2"
  shows "P. P  carrier_mat m m  invertible_mat P  FindPreHNF abs_flag D A = P * A"
  using assms
  by (auto, metis invertible_mat_one left_mult_one_mat one_carrier_mat)


lemma FindPreHNF_invertible_mat_mx2:
  assumes A_def: "A = A'' @r D m 1m n"
  and A'': "A''  carrier_mat m n" and n2: "n<2" and n0: "0<n" and D_g0: "D>0" and mn: "mn"
shows "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  FindPreHNF abs_flag D A = P * A"
proof -
  have A: "A  carrier_mat (m+n) n" using A_def A'' by auto
  have m0: "m>0" using mn n2 n0 by auto
  have D0: "D0" using D_g0 by auto
  show ?thesis
  proof (cases "m+n<2")
    case True
    show ?thesis by (rule FindPreHNF_invertible_mat_2xn[OF A True])
  next
    case False note mn_le_2 = False
    have dr_A: "dim_row A 2" using False n2 A by auto
    have dc_A: "dim_col A < 2" using n2 A by auto
    let ?non_zero_positions = "filter (λi. A $$ (i, 0)  0) [Suc 0..<dim_row A]" 
    let ?A' = "(if A $$ (0, 0)  0 then A else let i = ?non_zero_positions ! 0 in swaprows 0 i A)"
    define xs where "xs = filter (λi. A $$ (i,0)  0) [1..<m]"
    let ?Reduce = "(if abs_flag then reduce_below_abs else reduce_below)"
    have nz_xs_m: "?non_zero_positions = xs @ [m]" and d_xs: "distinct xs"
      and all_less_m: "xset xs. x < m  0 < x" 
      using non_zero_positions_xs_m'[OF A_def A'' _ m0 n0 D0] using D0 A unfolding xs_def by auto  
    have *: "FindPreHNF abs_flag D A = (if abs_flag then reduce_below_abs 0 ?non_zero_positions D ?A' 
        else reduce_below 0 ?non_zero_positions D ?A')"
      using dr_A dc_A by (auto simp add: Let_def) 
    have l: "length ?non_zero_positions > 1" if "xs[]" using that unfolding nz_xs_m by auto
    have inv: "P. invertible_mat P  P  carrier_mat (m + n) (m + n) 
       reduce_below 0 ?non_zero_positions D ?A' = P * ?A'"
    proof (cases "A $$ (0,0) 0")
      case True
      show ?thesis
        by (unfold nz_xs_m, rule reduce_below_invertible_mat_case_m
            [OF A'' m0 n0 _ _ mn d_xs all_less_m], insert A_def True D_g0, auto)
    next
      case False hence A00: "A $$ (0,0) = 0" by auto
      let ?S = "swaprows 0 (?non_zero_positions ! 0) A"
      have rw: "(if A $$ (0, 0)  0 then A else let i = ?non_zero_positions ! 0 in swaprows 0 i A)
          = ?S" using False by auto
      show ?thesis
      proof (cases "xs = []")
        case True
        have nz_m: "?non_zero_positions = [m]" using True nz_xs_m by simp
        obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (swaprows 0 m A $$ (0, 0)) (swaprows 0 m A $$ (m, 0))"
          by (metis prod_cases5)        
        have Am0: "A $$ (m,0) = D"
        proof -
          have "A $$ (m,0) = (D m 1m n) $$ (m-m, 0)"
            by (smt (z3) A append_rows_def A_def A'' n0 carrier_matD diff_self_eq_0 index_mat_four_block
                less_add_same_cancel1 less_diff_conv diff_add nat_less_le)
          also have "... = D" by (simp add: n0)
          finally show ?thesis .
        qed
        have Sm0: "(swaprows 0 m A) $$ (m,0) = 0" using A False n0 by auto
        have S00: "(swaprows 0 m A) $$ (0,0) = D" using A Am0 n0 by auto
        have pquvd2: "(p,q,u,v,d) = euclid_ext2 (A $$ (m, 0)) (A $$ (0, 0))"
          using pquvd Sm0 S00 Am0 A00 by auto
        have "reduce_below 0 ?non_zero_positions D ?A' = reduce 0 m D ?A'" unfolding nz_m by auto
        also have "... = reduce 0 m D (swaprows 0 m A)" using True False rw nz_m by auto
        have " P. invertible_mat P  P  carrier_mat (m + n) (m + n) 
           reduce 0 m D (swaprows 0 m A) = P * (swaprows 0 m A)"
        proof (rule reduce_invertible_mat_case_m[OF _ _ m0 _ _ _ _ mn n0])
          show "swaprows 0 m A $$ (0, 0)  0" using S00 D0 by auto
          define S' where  "S' = mat_of_rows n (map (Matrix.row ?S) [0..<m])"
          define S'' where "S'' = mat_of_rows n (map (Matrix.row ?S) [m..<m+n])"
          define A2 where "A2 = Matrix.mat (dim_row (swaprows 0 m A)) (dim_col (swaprows 0 m A))
             (λ(i, k). if i = 0 then p * A $$ (m, k) + q * A $$ (0, k)
             else if i = m then u * A $$ (m, k) + v * A $$ (0, k) else A $$ (i, k))"
          show S_S'_S'': "swaprows 0 m A = S' @r S''" unfolding S'_def S''_def
            by (metis A append_rows_split carrier_matD index_mat_swaprows(2,3) le_add1 nth_Cons_0 nz_m)
          show S': "S'  carrier_mat m n" unfolding S'_def by fastforce
          show S'': "S''  carrier_mat n n" unfolding S''_def by fastforce
          show "0  m" using m0 by simp
          show "(p,q,u,v,d) = euclid_ext2 (swaprows 0 m A $$ (0, 0)) (swaprows 0 m A $$ (m, 0))"
            using pquvd by simp
          show "A2 = Matrix.mat (dim_row (swaprows 0 m A)) (dim_col (swaprows 0 m A))
         (λ(i, k). if i = 0 then p * swaprows 0 m A $$ (0, k) + q * swaprows 0 m A $$ (m, k)
         else if i = m then u * swaprows 0 m A $$ (0, k) + v * swaprows 0 m A $$ (m, k) else swaprows 0 m A $$ (i, k))"
            (is "_ = ?rhs") using A A2_def by auto
          define xs' where "xs' = [1..<n]"
          define ys' where  "ys' = [1..<n]"
          show "xs' = [1..<n]" unfolding xs'_def by auto
          show "ys' = [1..<n]" unfolding ys'_def by auto
          have S''D: "(S'' $$ (j, j) = D)  (j'{0..<n}-{j}. S'' $$ (j, j') = 0)"
            if jn: "j<n" and j0: "j>0" for j
          proof -
            have "S'' $$ (j, i) = (D m 1m n) $$ (j,i)" if i_n: "i<n" for i
            proof -
              have "S'' $$ (j, i) = swaprows 0 m A $$ (j+m,i)"
                by (metis S' S'' S_S'_S'' append_rows_nth2 mn nat_SN.compat i_n jn)
              also have "... = A $$ (j+m,i)" using A jn j0 i_n by auto
              also have "... = (D m 1m n) $$ (j,i)"
                by (smt A Groups.add_ac(2) add_mono_thms_linordered_field(1) append_rows_def A_def A'' i_n
                    carrier_matD index_mat_four_block(1,2) add_diff_cancel_right' not_add_less2 jn trans_less_add1)
              finally show ?thesis .
            qed
            thus ?thesis using jn j0 by auto
          qed
          have "0  set xs'"
          proof -
            have "A2 $$ (0,0) = p * A $$ (m, 0) + q * A $$ (0, 0)" 
              using A A2_def n0 by auto
            also have "... = gcd (A $$ (m, 0)) (A $$ (0, 0))"
              by (metis euclid_ext2_works(1) euclid_ext2_works(2) pquvd2)
            also have "... = D" using Am0 A00 D_g0 by auto             
            finally have "A2 $$ (0,0) = D" .
            thus ?thesis unfolding xs'_def using D_g0 by auto
          qed
          thus "jset xs'. j<n  (S'' $$ (j, j) = D)  (j'{0..<n}-{j}. S'' $$ (j, j') = 0)"  
            using S''D xs'_def by auto
          have "0  set ys'"
          proof -
            have "A2 $$ (m,0) = u * A $$ (m, 0) + v * A $$ (0, 0)"
              using A A2_def n0 m0 by auto
            also have "... = - A $$ (0, 0) div gcd (A $$ (m, 0)) (A $$ (0, 0)) * A $$ (m, 0) 
              + A $$ (m, 0) div gcd (A $$ (m, 0)) (A $$ (0, 0)) * A $$ (0, 0)"
              by (simp add: euclid_ext2_works[OF pquvd2[symmetric]])
            also have "... = 0" using A00 Am0 by auto
            finally have "A2 $$ (m,0) = 0" .
            thus ?thesis unfolding ys'_def using D_g0 by auto
          qed
          thus "jset ys'. j<n  (S'' $$ (j, j) = D)  (j'{0..<n}-{j}. S'' $$ (j, j') = 0)"
            using S''D ys'_def by auto    
          show "swaprows 0 m A $$ (m, 0)  {0, D}" using Sm0 by blast
          thus "swaprows 0 m A $$ (m, 0) = 0  swaprows 0 m A $$ (0, 0) = D"
            using S00 by linarith                  
        qed (insert D_g0)      
        then show ?thesis by (simp add: False nz_m)
      next
        case False note xs_not_empty = False
        show ?thesis       
      proof (unfold nz_xs_m, rule reduce_below_invertible_mat_case_m[OF _ m0 n0 _ _ mn d_xs all_less_m D_g0])
        let ?S' = "mat_of_rows n (map (Matrix.row ?S) [0..<m])"
        show "?S'  carrier_mat m n" by auto
        have l: "length ?non_zero_positions > 1" using l False by blast
        hence nz0_less_m: "?non_zero_positions ! 0 < m"
          by (metis One_nat_def add.commute add.left_neutral all_less_m append_Cons_nth_left 
              length_append less_add_same_cancel1 list.size(3,4) nth_mem nz_xs_m)    
        have "?S = ?S' @r D m 1m n" by (rule swaprows_append_id[OF A'' A_def nz0_less_m])
        thus "(if A $$ (0, 0)  0 then A else let i = (xs @ [m]) ! 0 in swaprows 0 i A)= ?S' @r D m 1m n" 
          using rw nz_xs_m by argo
        have "?S $$ (0, 0)  0"
          by (smt A l add_pos_pos carrier_matD index_mat_swaprows(1) le_eq_less_or_eq length_greater_0_conv
              less_one linorder_not_less list.size(3) m0 mem_Collect_eq n0 nth_mem set_filter)
        thus "(if A $$ (0, 0)  0 then A else let i = (xs @ [m]) ! 0 in swaprows 0 i A) $$ (0, 0)  0"
          using rw nz_xs_m by algebra
      qed
    qed
  qed
    have inv2: "P. invertible_mat P  P  carrier_mat (m + n) (m + n) 
       reduce_below_abs 0 ?non_zero_positions D ?A' = P * ?A'"
    proof (cases "A $$ (0,0) 0")
      case True
      show ?thesis
        by (unfold nz_xs_m, rule reduce_below_abs_invertible_mat_case_m
            [OF A'' m0 n0 _ _ mn d_xs all_less_m], insert A_def True D_g0, auto)
    next
      case False hence A00: "A $$ (0,0) = 0" by auto
      let ?S = "swaprows 0 (?non_zero_positions ! 0) A"
      have rw: "(if A $$ (0, 0)  0 then A else let i = ?non_zero_positions ! 0 in swaprows 0 i A)
          = ?S" using False by auto
      show ?thesis
      proof (cases "xs = []")
        case True
        have nz_m: "?non_zero_positions = [m]" using True nz_xs_m by simp
        obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (swaprows 0 m A $$ (0, 0)) (swaprows 0 m A $$ (m, 0))"
          by (metis prod_cases5)        
        have Am0: "A $$ (m,0) = D"
        proof -
          have "A $$ (m,0) = (D m 1m n) $$ (m-m, 0)"
            by (smt (z3) A append_rows_def A_def A'' n0 carrier_matD diff_self_eq_0 index_mat_four_block
                less_add_same_cancel1 less_diff_conv diff_add nat_less_le)
          also have "... = D" by (simp add: n0)
          finally show ?thesis .
        qed
        have Sm0: "(swaprows 0 m A) $$ (m,0) = 0" using A False n0 by auto
        have S00: "(swaprows 0 m A) $$ (0,0) = D" using A Am0 n0 by auto
        have pquvd2: "(p,q,u,v,d) = euclid_ext2 (A $$ (m, 0)) (A $$ (0, 0))"
          using pquvd Sm0 S00 Am0 A00 by auto
        have "reduce_below 0 ?non_zero_positions D ?A' = reduce 0 m D ?A'" unfolding nz_m by auto
        also have "... = reduce 0 m D (swaprows 0 m A)" using True False rw nz_m by auto
        have " P. invertible_mat P  P  carrier_mat (m + n) (m + n) 
           reduce_abs 0 m D (swaprows 0 m A) = P * (swaprows 0 m A)"
        proof (rule reduce_abs_invertible_mat_case_m[OF _ _ m0 _ _ _ _ mn n0])
          show "swaprows 0 m A $$ (0, 0)  0" using S00 D0 by auto
          define S' where  "S' = mat_of_rows n (map (Matrix.row ?S) [0..<m])"
          define S'' where "S'' = mat_of_rows n (map (Matrix.row ?S) [m..<m+n])"
          define A2 where "A2 = Matrix.mat (dim_row (swaprows 0 m A)) (dim_col (swaprows 0 m A))
             (λ(i, k). if i = 0 then p * A $$ (m, k) + q * A $$ (0, k)
             else if i = m then u * A $$ (m, k) + v * A $$ (0, k) else A $$ (i, k))"
          show S_S'_S'': "swaprows 0 m A = S' @r S''" unfolding S'_def S''_def
            by (metis A append_rows_split carrier_matD index_mat_swaprows(2,3) le_add1 nth_Cons_0 nz_m)
          show S': "S'  carrier_mat m n" unfolding S'_def by fastforce
          show S'': "S''  carrier_mat n n" unfolding S''_def by fastforce
          show "0  m" using m0 by simp
          show "(p,q,u,v,d) = euclid_ext2 (swaprows 0 m A $$ (0, 0)) (swaprows 0 m A $$ (m, 0))"
            using pquvd by simp
          show "A2 = Matrix.mat (dim_row (swaprows 0 m A)) (dim_col (swaprows 0 m A))
         (λ(i, k). if i = 0 then p * swaprows 0 m A $$ (0, k) + q * swaprows 0 m A $$ (m, k)
         else if i = m then u * swaprows 0 m A $$ (0, k) + v * swaprows 0 m A $$ (m, k) else swaprows 0 m A $$ (i, k))"
            (is "_ = ?rhs") using A A2_def by auto
          define xs' where "xs' = filter (λi. abs (A2 $$ (0,i)) > D) [0..<n]"
          define ys' where  "ys' = filter (λi. abs (A2 $$ (m,i)) > D) [0..<n]"
          show "xs' = filter (λi. abs (A2 $$ (0,i)) > D) [0..<n]" unfolding xs'_def by auto
          show "ys' = filter (λi. abs (A2 $$ (m,i)) > D) [0..<n]" unfolding ys'_def by auto
          have S''D: "(S'' $$ (j, j) = D)  (j'{0..<n}-{j}. S'' $$ (j, j') = 0)"
            if jn: "j<n" and j0: "j>0" for j
          proof -
            have "S'' $$ (j, i) = (D m 1m n) $$ (j,i)" if i_n: "i<n" for i
            proof -
              have "S'' $$ (j, i) = swaprows 0 m A $$ (j+m,i)"
                by (metis S' S'' S_S'_S'' append_rows_nth2 mn nat_SN.compat i_n jn)
              also have "... = A $$ (j+m,i)" using A jn j0 i_n by auto
              also have "... = (D m 1m n) $$ (j,i)"
                by (smt A Groups.add_ac(2) add_mono_thms_linordered_field(1) append_rows_def A_def A'' i_n
                    carrier_matD index_mat_four_block(1,2) add_diff_cancel_right' not_add_less2 jn trans_less_add1)
              finally show ?thesis .
            qed
            thus ?thesis using jn j0 by auto
          qed
          have "0  set xs'"
          proof -
            have "A2 $$ (0,0) = p * A $$ (m, 0) + q * A $$ (0, 0)" 
              using A A2_def n0 by auto
            also have "... = gcd (A $$ (m, 0)) (A $$ (0, 0))"
              by (metis euclid_ext2_works(1) euclid_ext2_works(2) pquvd2)
            also have "... = D" using Am0 A00 D_g0 by auto             
            finally have "A2 $$ (0,0) = D" .
            thus ?thesis unfolding xs'_def using D_g0 by auto
          qed
          thus "jset xs'. j<n  (S'' $$ (j, j) = D)  (j'{0..<n}-{j}. S'' $$ (j, j') = 0)"  
            using S''D xs'_def by auto
          have "0  set ys'"
          proof -
            have "A2 $$ (m,0) = u * A $$ (m, 0) + v * A $$ (0, 0)"
              using A A2_def n0 m0 by auto
            also have "... = - A $$ (0, 0) div gcd (A $$ (m, 0)) (A $$ (0, 0)) * A $$ (m, 0) 
              + A $$ (m, 0) div gcd (A $$ (m, 0)) (A $$ (0, 0)) * A $$ (0, 0)"
              by (simp add: euclid_ext2_works[OF pquvd2[symmetric]])
            also have "... = 0" using A00 Am0 by auto
            finally have "A2 $$ (m,0) = 0" .
            thus ?thesis unfolding ys'_def using D_g0 by auto
          qed
          thus "jset ys'. j<n  (S'' $$ (j, j) = D)  (j'{0..<n}-{j}. S'' $$ (j, j') = 0)"
            using S''D ys'_def by auto    
        qed (insert D_g0)      
        then show ?thesis by (simp add: False nz_m)
      next
        case False note xs_not_empty = False
        show ?thesis       
      proof (unfold nz_xs_m, rule reduce_below_abs_invertible_mat_case_m[OF _ m0 n0 _ _ mn d_xs all_less_m D_g0])
        let ?S' = "mat_of_rows n (map (Matrix.row ?S) [0..<m])"
        show "?S'  carrier_mat m n" by auto
        have l: "length ?non_zero_positions > 1" using l False by blast
        hence nz0_less_m: "?non_zero_positions ! 0 < m"
          by (metis One_nat_def add.commute add.left_neutral all_less_m append_Cons_nth_left 
              length_append less_add_same_cancel1 list.size(3,4) nth_mem nz_xs_m)    
        have "?S = ?S' @r D m 1m n" by (rule swaprows_append_id[OF A'' A_def nz0_less_m])
        thus "(if A $$ (0, 0)  0 then A else let i = (xs @ [m]) ! 0 in swaprows 0 i A)= ?S' @r D m 1m n" 
          using rw nz_xs_m by argo
        have "?S $$ (0, 0)  0"
          by (smt A l add_pos_pos carrier_matD index_mat_swaprows(1) le_eq_less_or_eq length_greater_0_conv
              less_one linorder_not_less list.size(3) m0 mem_Collect_eq n0 nth_mem set_filter)
        thus "(if A $$ (0, 0)  0 then A else let i = (xs @ [m]) ! 0 in swaprows 0 i A) $$ (0, 0)  0"
          using rw nz_xs_m by algebra
      qed
    qed
  qed
  show ?thesis
  proof (cases abs_flag)
    case False
    from inv obtain P where inv_P: "invertible_mat P" and P: "P  carrier_mat (m + n) (m + n)"
      and r_PA': "reduce_below 0 ?non_zero_positions D ?A' = P * ?A'" by blast
    have Find_rw: "FindPreHNF abs_flag D A = reduce_below 0 ?non_zero_positions D ?A'"
      using n0 A dr_A dc_A False * by (auto simp add: Let_def)
    have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P  ?A' = P * A" 
      by (rule A'_swaprows_invertible_mat[OF A], insert non_zero_positions_xs_m n0 m0 l nz_xs_m, auto) 
    from this obtain Q where Q: "Q  carrier_mat (m + n) (m + n)"
      and inv_Q: "invertible_mat Q" and A'_QA: "?A' = Q * A" by blast
    have "reduce_below 0 ?non_zero_positions D ?A' = (P * Q) * A" using Q A'_QA P r_PA' A by auto
    moreover have "invertible_mat (P*Q)" using P Q inv_P inv_Q invertible_mult_JNF by blast
    moreover have "(P*Q)  carrier_mat (m + n) (m + n)" using P Q by auto
    ultimately show ?thesis using Find_rw by metis
  next
    case True
    from inv2 obtain P where inv_P: "invertible_mat P" and P: "P  carrier_mat (m + n) (m + n)"
      and r_PA': "reduce_below_abs 0 ?non_zero_positions D ?A' = P * ?A'" by blast
    have Find_rw: "FindPreHNF abs_flag D A = reduce_below_abs 0 ?non_zero_positions D ?A'"
      using n0 A dr_A dc_A True * by (auto simp add: Let_def)
    have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P  ?A' = P * A" 
      by (rule A'_swaprows_invertible_mat[OF A], insert non_zero_positions_xs_m n0 m0 l nz_xs_m, auto) 
    from this obtain Q where Q: "Q  carrier_mat (m + n) (m + n)"
      and inv_Q: "invertible_mat Q" and A'_QA: "?A' = Q * A" by blast
    have "reduce_below_abs 0 ?non_zero_positions D ?A' = (P * Q) * A" using Q A'_QA P r_PA' A by auto
    moreover have "invertible_mat (P*Q)" using P Q inv_P inv_Q invertible_mult_JNF by blast
    moreover have "(P*Q)  carrier_mat (m + n) (m + n)" using P Q by auto
    ultimately show ?thesis using Find_rw by metis
  qed     
  qed
qed


corollary FindPreHNF_echelon_form_mx0:
  assumes "A  carrier_mat m 0"
  shows "echelon_form_JNF (FindPreHNF abs_flag D A)"
  by (rule echelon_form_mx0, rule FindPreHNF[OF assms])
               

lemma FindPreHNF_echelon_form_mx1:
  assumes A_def: "A = A'' @r D m 1m n"
  and A'': "A''  carrier_mat m n" and n2: "n<2" and D_g0: "D>0" and mn: "mn"
shows "echelon_form_JNF (FindPreHNF abs_flag D A)"
proof (cases "n=0")
  case True
  have A: "A  carrier_mat m 0" using A_def A'' True 
    by (metis add.comm_neutral append_rows_def carrier_matD carrier_matI index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3)) 
  show ?thesis unfolding True by (rule FindPreHNF_echelon_form_mx0, insert A, auto)
next
  case False hence n0: "0<n" by auto
  have A: "A  carrier_mat (m+n) n" using A_def A'' by auto
  have m0: "m>0" using mn n2 n0 by auto
  have D0: "D0" using D_g0 by auto
  show ?thesis
  proof (cases "m+n<2")
    case True
    show ?thesis by (rule echelon_form_JNF_1xn[OF _ True], rule FindPreHNF[OF A])
  next
    case False note mn_le_2 = False
    have dr_A: "dim_row A 2" using False n2 A by auto
    have dc_A: "dim_col A < 2" using n2 A by auto
    let ?non_zero_positions = "filter (λi. A $$ (i, 0)  0) [Suc 0..<dim_row A]" 
    let ?A' = "(if A $$ (0, 0)  0 then A else let i = ?non_zero_positions ! 0 in swaprows 0 i A)" 
    define xs where "xs = filter (λi. A $$ (i,0)  0) [1..<m]"
    let ?Reduce = "(if abs_flag then reduce_below_abs else reduce_below)"
    have nz_xs_m: "?non_zero_positions = xs @ [m]" and d_xs: "distinct xs"
      and all_less_m: "xset xs. x < m  0 < x" 
      using non_zero_positions_xs_m'[OF A_def A'' _ m0 n0 D0] using D0 A unfolding xs_def by auto  
    have *: "FindPreHNF abs_flag D A = (if abs_flag then reduce_below_abs 0 ?non_zero_positions D ?A' 
        else reduce_below 0 ?non_zero_positions D ?A')"
      using dr_A dc_A by (auto simp add: Let_def) 
    have l: "length ?non_zero_positions > 1" if "xs[]" using that unfolding nz_xs_m by auto
    have e: "echelon_form_JNF (reduce_below 0 ?non_zero_positions D ?A')"
    proof (cases "A $$ (0,0) 0")
      case True note A00 = True
      have 1: "reduce_below 0 ?non_zero_positions D ?A' = reduce_below 0 ?non_zero_positions D A"
        using True by auto
      have "echelon_form_JNF (reduce_below 0 ?non_zero_positions D A)"
      proof (rule echelon_form_JNF_mx1[OF _ n2]) 
        show "reduce_below 0 ?non_zero_positions D A  carrier_mat (m+n) n" using A by auto
        show "i{1..<m + n}. reduce_below 0 ?non_zero_positions D A $$ (i, 0) = 0"
        proof 
          fix i assume i: "i  {1..<m + n}"
          show "reduce_below 0 ?non_zero_positions D A $$ (i, 0) =0"
          proof (cases "iset ?non_zero_positions")
            case True
            show ?thesis unfolding nz_xs_m 
              by (rule reduce_below_0_case_m[OF A'' m0 n0 A_def A00 mn _ d_xs all_less_m D_g0],
                  insert nz_xs_m True, auto)
          next
            case False note i_notin_set = False
            have "reduce_below 0 ?non_zero_positions D A $$ (i, 0) = A $$ (i, 0)" unfolding nz_xs_m 
              by (rule reduce_below_preserves_case_m[OF A'' m0 n0 A_def A00 mn _ d_xs all_less_m _ _ _ D_g0],
                  insert i nz_xs_m i_notin_set, auto)
            also have "... = 0" using i_notin_set i A unfolding set_filter by auto
            finally show ?thesis .        
          qed
        qed
      qed
      thus ?thesis using 1 by argo
    next
      case False hence A00: "A $$ (0,0) = 0" by simp
      let ?i = "((xs @ [m]) ! 0)"
      let ?S = "swaprows 0 ?i A"
      let ?S' = "mat_of_rows n (map (Matrix.row (swaprows 0 ?i A)) [0..<m])"
      have rw: "(if A$$(0, 0)  0 then A else let i = ?non_zero_positions!0 in swaprows 0 i A) = ?S"
        using A00 nz_xs_m by auto
      have S: "?S  carrier_mat (m+n) n" using A by auto
      have A00_eq_A'00: "A $$ (0, 0) = A'' $$ (0, 0)" 
        by (metis A'' A_def add_gr_0 append_rows_def n0 carrier_matD index_mat_four_block(1) m0)
      show ?thesis
      proof (cases "xs=[]")
        case True
        have nz_m: "?non_zero_positions = [m]" using True nz_xs_m by simp
        obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (swaprows 0 m A $$ (0, 0)) (swaprows 0 m A $$ (m, 0))"
          by (metis prod_cases5)        
        have Am0: "A $$ (m,0) = D"
        proof -
          have "A $$ (m,0) = (D m 1m n) $$ (m-m, 0)"
            by (smt A append_rows_def A_def A'' n0 carrier_matD diff_self_eq_0 index_mat_four_block
                less_add_same_cancel1 less_diff_conv ordered_cancel_comm_monoid_diff_class.diff_add
                nat_less_le)
          also have "... = D" by (simp add: n0)
          finally show ?thesis .
        qed
        have Sm0: "(swaprows 0 m A) $$ (m,0) = 0" using A False n0 by auto
        have S00: "(swaprows 0 m A) $$ (0,0) = D" using A Am0 n0 by auto
        have pquvd2: "(p,q,u,v,d) = euclid_ext2 (A $$ (m, 0)) (A $$ (0, 0))"
          using pquvd Sm0 S00 Am0 A00 by auto
        have "reduce_below 0 ?non_zero_positions D ?A' = reduce 0 m D ?A'" unfolding nz_m by auto
        also have "... = reduce 0 m D (swaprows 0 m A)" using True False rw nz_m by auto
        finally have *: "reduce_below 0 ?non_zero_positions D ?A' = reduce 0 m D (swaprows 0 m A)" .
        have "echelon_form_JNF (reduce 0 m D (swaprows 0 m A))"
        proof (rule echelon_form_JNF_mx1[OF _ n2])
          show "reduce 0 m D (swaprows 0 m A)  carrier_mat (m+n) n"
            using A n2 reduce_carrier by (auto simp add: Let_def) 
          show "i{1..<m+n}. reduce 0 m D (swaprows 0 m A) $$ (i, 0) = 0"
          proof
            fix i assume i: "i  {1..<m+n}"
            show "reduce 0 m D (swaprows 0 m A) $$ (i, 0) = 0"
            proof (cases "i=m")
              case True
              show ?thesis
              proof (unfold True, rule reduce_0[OF _ _ n0])
                show "swaprows 0 m A  carrier_mat (m+n) n" using A by auto
              qed (insert m0 n0 S00 D_g0, auto)
            next
              case False
              have "reduce 0 m D (swaprows 0 m A) $$ (i, 0) = (swaprows 0 m A) $$ (i, 0)"
              proof (rule reduce_preserves[OF _ n0])
                show "swaprows 0 m A  carrier_mat (m+n) n" using A by auto  
              qed (insert m0 n0 S00 D_g0 False i, auto)
              also have "... = A $$ (i, 0)" using i False A n0 by auto
              also have "... = 0"
              proof (rule ccontr)
                assume "A $$ (i, 0)  0" hence "i  set ?non_zero_positions" using i A by auto 
                hence "i=m" using nz_xs_m True by auto
                thus False using False by contradiction
              qed
              finally show ?thesis .
            qed 
          qed
        qed       
        then show ?thesis using * by presburger
      next
        case False        
      have l: "length ?non_zero_positions > 1"    using False nz_xs_m by auto   
      hence l_xs: "length xs > 0" using nz_xs_m by auto
      hence xs_m_less_m: "(xs@[m]) ! 0 < m" by (simp add: all_less_m nth_append)
      have S00: "?S $$ (0,0)  0"
        by (smt A add_pos_pos append_Cons_nth_left n0 carrier_matD index_mat_swaprows(1)
            l_xs m0 mem_Collect_eq nth_mem set_filter xs_def)
      have S': "?S'  carrier_mat m n" using A by auto
      have S_S'D: "?S = ?S' @r D m 1m n" by (rule swaprows_append_id[OF A'' A_def xs_m_less_m]) 
      have 2: "reduce_below 0 ?non_zero_positions D ?A' = reduce_below 0 ?non_zero_positions D ?S"
        using A00 nz_xs_m by algebra
      have "echelon_form_JNF (reduce_below 0 ?non_zero_positions D ?S)"
      proof (rule echelon_form_JNF_mx1[OF _ n2])
        show "reduce_below 0 ?non_zero_positions D ?S  carrier_mat (m+n) n" using A by auto
        show "i{1..<m + n}. reduce_below 0 ?non_zero_positions D ?S $$ (i, 0) = 0"
        proof 
          fix i assume i: "i  {1..<m + n}"
          show "reduce_below 0 ?non_zero_positions D ?S $$ (i, 0) =0"
          proof (cases "iset ?non_zero_positions")
            case True
            show ?thesis unfolding nz_xs_m 
              by (rule reduce_below_0_case_m[OF S' m0 n0 S_S'D S00 mn _ d_xs all_less_m D_g0],
                  insert True nz_xs_m, auto)
          next
            case False note i_notin_set = False
            have "reduce_below 0 ?non_zero_positions D ?S $$ (i, 0) = ?S $$ (i, 0)" unfolding nz_xs_m 
              by (rule reduce_below_preserves_case_m[OF S' m0 n0 S_S'D S00 mn _ d_xs all_less_m _ _ _ D_g0],
                  insert i nz_xs_m i_notin_set, auto)
            also have "... = 0" using i_notin_set i A S00 n0 unfolding set_filter by auto              
            finally show ?thesis .        
          qed
        qed
      qed
      thus ?thesis using 2 by argo
    qed
  qed
    have e2: "echelon_form_JNF (reduce_below_abs 0 ?non_zero_positions D ?A')"
    proof (cases "A $$ (0,0) 0")
      case True note A00 = True
      have 1: "reduce_below_abs 0 ?non_zero_positions D ?A' = reduce_below_abs 0 ?non_zero_positions D A"
        using True by auto
      have "echelon_form_JNF (reduce_below_abs 0 ?non_zero_positions D A)"
      proof (rule echelon_form_JNF_mx1[OF _ n2]) 
        show "reduce_below_abs 0 ?non_zero_positions D A  carrier_mat (m+n) n" using A by auto
        show "i{1..<m + n}. reduce_below_abs 0 ?non_zero_positions D A $$ (i, 0) = 0"
        proof 
          fix i assume i: "i  {1..<m + n}"
          show "reduce_below_abs 0 ?non_zero_positions D A $$ (i, 0) =0"
          proof (cases "iset ?non_zero_positions")
            case True
            show ?thesis unfolding nz_xs_m 
              by (rule reduce_below_abs_0_case_m[OF A'' m0 n0 A_def A00 mn _ d_xs all_less_m D_g0],
                  insert nz_xs_m True, auto)
          next
            case False note i_notin_set = False
            have "reduce_below_abs 0 ?non_zero_positions D A $$ (i, 0) = A $$ (i, 0)" unfolding nz_xs_m 
              by (rule reduce_below_abs_preserves_case_m[OF A'' m0 n0 A_def A00 mn _ d_xs all_less_m _ _ _ D_g0],
                  insert i nz_xs_m i_notin_set, auto)
            also have "... = 0" using i_notin_set i A unfolding set_filter by auto
            finally show ?thesis .        
          qed
        qed
      qed
      thus ?thesis using 1 by argo
    next
      case False hence A00: "A $$ (0,0) = 0" by simp
      let ?i = "((xs @ [m]) ! 0)"
      let ?S = "swaprows 0 ?i A"
      let ?S' = "mat_of_rows n (map (Matrix.row (swaprows 0 ?i A)) [0..<m])"
      have rw: "(if A$$(0, 0)  0 then A else let i = ?non_zero_positions!0 in swaprows 0 i A) = ?S"
        using A00 nz_xs_m by auto
      have S: "?S  carrier_mat (m+n) n" using A by auto
      have A00_eq_A'00: "A $$ (0, 0) = A'' $$ (0, 0)" 
        by (metis A'' A_def add_gr_0 append_rows_def n0 carrier_matD index_mat_four_block(1) m0)
      show ?thesis
      proof (cases "xs=[]")
        case True
        have nz_m: "?non_zero_positions = [m]" using True nz_xs_m by simp
        obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (swaprows 0 m A $$ (0, 0)) (swaprows 0 m A $$ (m, 0))"
          by (metis prod_cases5)        
        have Am0: "A $$ (m,0) = D"
        proof -
          have "A $$ (m,0) = (D m 1m n) $$ (m-m, 0)"
            by (smt A append_rows_def A_def A'' n0 carrier_matD diff_self_eq_0 index_mat_four_block
                less_add_same_cancel1 less_diff_conv ordered_cancel_comm_monoid_diff_class.diff_add
                nat_less_le)
          also have "... = D" by (simp add: n0)
          finally show ?thesis .
        qed
        have Sm0: "(swaprows 0 m A) $$ (m,0) = 0" using A False n0 by auto
        have S00: "(swaprows 0 m A) $$ (0,0) = D" using A Am0 n0 by auto
        have pquvd2: "(p,q,u,v,d) = euclid_ext2 (A $$ (m, 0)) (A $$ (0, 0))"
          using pquvd Sm0 S00 Am0 A00 by auto
        have "reduce_below_abs 0 ?non_zero_positions D ?A' = reduce_abs 0 m D ?A'" unfolding nz_m by auto
        also have "... = reduce_abs 0 m D (swaprows 0 m A)" using True False rw nz_m by auto
        finally have *: "reduce_below_abs 0 ?non_zero_positions D ?A' = reduce_abs 0 m D (swaprows 0 m A)" .
        have "echelon_form_JNF (reduce_abs 0 m D (swaprows 0 m A))"
        proof (rule echelon_form_JNF_mx1[OF _ n2])
          show "reduce_abs 0 m D (swaprows 0 m A)  carrier_mat (m+n) n"
            using A n2 reduce_carrier by (auto simp add: Let_def) 
          show "i{1..<m+n}. reduce_abs 0 m D (swaprows 0 m A) $$ (i, 0) = 0"
          proof
            fix i assume i: "i  {1..<m+n}"
            show "reduce_abs 0 m D (swaprows 0 m A) $$ (i, 0) = 0"
            proof (cases "i=m")
              case True
              show ?thesis
              proof (unfold True, rule reduce_0[OF _ _ n0])
                show "swaprows 0 m A  carrier_mat (m+n) n" using A by auto
              qed (insert m0 n0 S00 D_g0, auto)
            next
              case False
              have "reduce_abs 0 m D (swaprows 0 m A) $$ (i, 0) = (swaprows 0 m A) $$ (i, 0)"
              proof (rule reduce_preserves[OF _ n0])
                show "swaprows 0 m A  carrier_mat (m+n) n" using A by auto  
              qed (insert m0 n0 S00 D_g0 False i, auto)
              also have "... = A $$ (i, 0)" using i False A n0 by auto
              also have "... = 0"
              proof (rule ccontr)
                assume "A $$ (i, 0)  0" hence "i  set ?non_zero_positions" using i A by auto 
                hence "i=m" using nz_xs_m True by auto
                thus False using False by contradiction
              qed
              finally show ?thesis .
            qed 
          qed
        qed       
        then show ?thesis using * by presburger
      next
        case False        
      have l: "length ?non_zero_positions > 1"    using False nz_xs_m by auto   
      hence l_xs: "length xs > 0" using nz_xs_m by auto
      hence xs_m_less_m: "(xs@[m]) ! 0 < m" by (simp add: all_less_m nth_append)
      have S00: "?S $$ (0,0)  0"
        by (smt A add_pos_pos append_Cons_nth_left n0 carrier_matD index_mat_swaprows(1)
            l_xs m0 mem_Collect_eq nth_mem set_filter xs_def)
      have S': "?S'  carrier_mat m n" using A by auto
      have S_S'D: "?S = ?S' @r D m 1m n" by (rule swaprows_append_id[OF A'' A_def xs_m_less_m]) 
      have 2: "reduce_below_abs 0 ?non_zero_positions D ?A' = reduce_below_abs 0 ?non_zero_positions D ?S"
        using A00 nz_xs_m by algebra
      have "echelon_form_JNF (reduce_below_abs 0 ?non_zero_positions D ?S)"
      proof (rule echelon_form_JNF_mx1[OF _ n2])
        show "reduce_below_abs 0 ?non_zero_positions D ?S  carrier_mat (m+n) n" using A by auto
        show "i{1..<m + n}. reduce_below_abs 0 ?non_zero_positions D ?S $$ (i, 0) = 0"
        proof 
          fix i assume i: "i  {1..<m + n}"
          show "reduce_below_abs 0 ?non_zero_positions D ?S $$ (i, 0) =0"
          proof (cases "iset ?non_zero_positions")
            case True
            show ?thesis unfolding nz_xs_m 
              by (rule reduce_below_abs_0_case_m[OF S' m0 n0 S_S'D S00 mn _ d_xs all_less_m D_g0],
                  insert True nz_xs_m, auto)
          next
            case False note i_notin_set = False
            have "reduce_below_abs 0 ?non_zero_positions D ?S $$ (i, 0) = ?S $$ (i, 0)" unfolding nz_xs_m 
              by (rule reduce_below_abs_preserves_case_m[OF S' m0 n0 S_S'D S00 mn _ d_xs all_less_m _ _ _ D_g0],
                  insert i nz_xs_m i_notin_set, auto)
            also have "... = 0" using i_notin_set i A S00 n0 unfolding set_filter by auto              
            finally show ?thesis .        
          qed
        qed
      qed
      thus ?thesis using 2 by argo
    qed
  qed
    thus ?thesis using * e by presburger
  qed
qed


lemma FindPreHNF_works_n_ge2:
  assumes A_def: "A = A'' @r D m 1m n"
  and A'': "A''  carrier_mat m n" and "n2" and m_le_n: "mn" and "D>0"
shows "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  FindPreHNF abs_flag D A = P * A  echelon_form_JNF (FindPreHNF abs_flag D A)"
  using assms
proof (induct abs_flag D A arbitrary: A'' m n rule: FindPreHNF.induct)
  case (1 abs_flag D A)  
  note A_def = "1.prems"(1)
  note A'' = "1.prems"(2)
  note n = "1.prems"(3)
  note m_le_n = "1.prems"(4)
  note D0 = "1.prems"(5)
  let ?RAT = "map_mat rat_of_int"
  have A: "A  carrier_mat (m+n) n" using A_def A'' by auto
  have mn: "2m+n" using n by auto
  have m0: "0<m" using n m_le_n by auto
  have n0: "0<n" using n by simp
  have D_not0: "D0" using D0 by auto
  define non_zero_positions where "non_zero_positions = filter (λi. A $$ (i,0)  0) [1..<dim_row A]"
  define A' where "A' = (if A $$ (0, 0)  0 then A else let i = non_zero_positions ! 0 in swaprows 0 i A)"
  let ?Reduce = "(if abs_flag then reduce_below_abs else reduce_below)"
  obtain A'_UL A'_UR A'_DL A'_DR where A'_split: "(A'_UL, A'_UR, A'_DL, A'_DR) 
    = split_block (?Reduce 0 non_zero_positions D (make_first_column_positive A')) 1 1"     
    by (metis prod_cases4)
  define sub_PreHNF where "sub_PreHNF = FindPreHNF abs_flag D A'_DR"
  obtain xs where non_zero_positions_xs_m: "non_zero_positions = xs @ [m]" and d_xs: "distinct xs"
    and all_less_m: "xset xs. x < m  0 < x" 
    using non_zero_positions_xs_m[OF A_def A'' non_zero_positions_def m0 n0] using D0 by fast
  define M where "M = (make_first_column_positive A')"  
  have A': "A'  carrier_mat (m+n) n" unfolding A'_def using A by auto 
  have mk_A'_not0:"make_first_column_positive A' $$ (0,0)  0"
    by (rule make_first_column_positive_00[OF A_def A'' non_zero_positions_def
          A'_def m0 n0 D_not0 m_le_n])  
  have M: "M  carrier_mat (m+n) n" using A' M_def by auto
  let ?M' = "mat_of_rows n (map (Matrix.row (make_first_column_positive A')) [0..<m])"
  have M': "?M'  carrier_mat m n" by auto            
  have M_M'D: "make_first_column_positive A' = ?M' @r D m 1m n" if xs_empty: "xs  []"
  proof (cases "A$$(0,0)  0")
    case True
    then have *: "make_first_column_positive A' = make_first_column_positive A"
      unfolding A'_def by auto        
    show ?thesis 
      by (unfold *, rule make_first_column_positive_append_id[OF A'' A_def D0 n0])
  next
    case False
    then have *: "make_first_column_positive A' 
                  = make_first_column_positive (swaprows 0 (non_zero_positions ! 0) A)"
      unfolding A'_def by auto
    show ?thesis
    proof (unfold *, rule make_first_column_positive_append_id)
      let ?S = "mat_of_rows n (map (Matrix.row (swaprows 0 (non_zero_positions ! 0) A)) [0..<m])"
      show "swaprows 0 (non_zero_positions ! 0) A =  ?S @r (D m (1m n))"
      proof (rule swaprows_append_id[OF A'' A_def])
        have A''00: "A'' $$ (0, 0) = 0"
          by (metis (no_types, lifting) A A'' A_def False add_sign_intros(2) append_rows_def
              carrier_matD index_mat_four_block m0 n0)
        have length_xs: "length xs > 0" using xs_empty by auto
        have "non_zero_positions ! 0 = xs ! 0" unfolding non_zero_positions_xs_m
          by (meson length_xs nth_append)
        thus "non_zero_positions ! 0 < m" using all_less_m length_xs by simp
      qed
    qed (insert n0 D0, auto)            
  qed
  have A'_DR: "A'_DR  carrier_mat (m + (n-1)) (n-1)"
    by (rule split_block(4)[OF A'_split[symmetric]], insert n M M_def, auto)  
  have sub_PreHNF: "sub_PreHNF  carrier_mat (m + (n -1)) (n-1)"
    unfolding sub_PreHNF_def by (rule FindPreHNF[OF A'_DR])
  hence sub_PreHNF': "sub_PreHNF  carrier_mat (m+n - 1) (n-1)" using n by auto
  have A'_UL: "A'_UL  carrier_mat 1 1"
    by (rule split_block(1)[OF A'_split[symmetric], of "m+n-1" "n-1"], insert n A', auto) 
  have A'_UR: "A'_UR  carrier_mat 1 (n-1)"
    by (rule split_block(2)[OF A'_split[symmetric], of "m+n-1"], insert n A', auto)
  have A'_DL: "A'_DL  carrier_mat (m + (n - 1)) 1"
    by (rule split_block(3)[OF A'_split[symmetric], of _ "n-1"], insert n A', auto)

  show ?case
  proof (cases abs_flag)
    case True note abs_flag = True
      hence A'_split: "(A'_UL, A'_UR, A'_DL, A'_DR) 
    = split_block (reduce_below_abs 0 non_zero_positions D (make_first_column_positive A')) 1 1"   using A'_split by auto
    let ?R = "reduce_below_abs 0 non_zero_positions D (make_first_column_positive A')"
   have fbm_R: "four_block_mat A'_UL A'_UR A'_DL A'_DR 
     = reduce_below_abs 0 non_zero_positions D (make_first_column_positive A')"
    by (rule split_block(5)[symmetric, OF A'_split[symmetric], of "m+n-1" "n-1"], insert A' n, auto)
  have A'_DL0: "A'_DL = (0m (m + (n - 1)) 1)"   
  proof (rule eq_matI)
    show "dim_row A'_DL = dim_row (0m (m + (n - 1)) 1)"
      and "dim_col A'_DL = dim_col (0m (m + (n - 1)) 1)" using A'_DL by auto    
    fix i j assume i: "i < dim_row (0m (m + (n - 1)) 1)" and j: "j < dim_col (0m (m + (n - 1)) 1)"
    have j0: "j=0" using j by auto
    have "0 = ?R $$ (i+1,j)"
    proof (unfold M_def non_zero_positions_xs_m j0, 
        rule reduce_below_abs_0_case_m_make_first_column_positive[symmetric,
          OF A'' m0 n0 A_def m_le_n _  d_xs all_less_m _ _ D0 _ ])
      show "A' = (if A $$ (0, 0)  0 then A else let i = (xs @ [m]) ! 0 in swaprows 0 i A)"
        using A'_def non_zero_positions_def non_zero_positions_xs_m by presburger
      show "xs @ [m] = filter (λi. A $$ (i, 0)  0) [1..<dim_row A]"
        using A'_def non_zero_positions_def non_zero_positions_xs_m by presburger
    qed (insert i n0, auto)
    also have "... = four_block_mat A'_UL A'_UR A'_DL A'_DR $$ (i+1,j)" unfolding fbm_R ..
    also have "... = (if i+1 < dim_row A'_UL then if j < dim_col A'_UL 
            then A'_UL $$ (i+1, j) else A'_UR $$ (i+1, j - dim_col A'_UL)
            else if j < dim_col A'_UL then A'_DL $$ (i+1 - dim_row A'_UL, j)
            else A'_DR $$ (i+1 - dim_row A'_UL, j - dim_col A'_UL))"
      by (rule index_mat_four_block, insert A'_UL A'_DR i j, auto)
    also have "... = A'_DL $$ (i, j)" using A'_UL A'_UR i j by auto
    finally show "A'_DL $$ (i, j) = 0m (m + (n - 1)) 1 $$ (i, j)" using i j by auto
  qed

  let ?A'_DR_m = "mat_of_rows (n-1) [Matrix.row A'_DR i. i  [0..<m]]"
  have A'_DR_m: "?A'_DR_m  carrier_mat m (n-1)" by auto
  have A'DR_A'DR_m_D: "A'_DR = ?A'_DR_m @r D m 1m (n - 1)"
  proof (rule eq_matI)
    show dr: "dim_row A'_DR = dim_row (?A'_DR_m @r D m 1m (n - 1))" 
      by (metis A'_DR A'_DR_m append_rows_def carrier_matD(1) index_mat_four_block(2) 
          index_one_mat(2) index_smult_mat(2) index_zero_mat(2))
    show dc: "dim_col A'_DR = dim_col (?A'_DR_m @r D m 1m (n - 1))"
      by (metis A'_DR A'_DR_m add.comm_neutral append_rows_def
          carrier_matD(2) index_mat_four_block(3) index_zero_mat(3))  
    fix i j assume i: "i < dim_row(?A'_DR_m @r D m 1m (n - 1))"
      and j: "j<dim_col (?A'_DR_m @r D m 1m (n - 1))"
    have jn1: "j<n-1" using dc j A'_DR by auto
    show "A'_DR $$ (i,j) = (?A'_DR_m @r D m 1m (n - 1)) $$ (i,j)"
    proof (cases "i<m")
      case True
      have "A'_DR $$ (i,j) = ?A'_DR_m $$ (i,j)"
        by (metis A'_DR A'_DR_m True dc carrier_matD(1) carrier_matD(2) j le_add1 
            map_first_rows_index mat_of_rows_carrier(2) mat_of_rows_index)
      also have "... = (?A'_DR_m @r D m 1m (n - 1)) $$ (i,j)"
        by (metis (mono_tags, lifting) A'_DR A'_DR_m True append_rows_def 
            carrier_matD dc i index_mat_four_block j)
      finally show ?thesis .
    next
      case False note i_ge_m = False
      let ?reduce_below = "reduce_below_abs 0 non_zero_positions D (make_first_column_positive A')"
      have 1: "(?A'_DR_m @r D m 1m (n - 1)) $$ (i,j) = (D m 1m (n - 1)) $$ (i-m,j)"
        by (smt A'_DR A'_DR_m False append_rows_nth carrier_matD carrier_mat_triv dc dr i
            index_one_mat(2) index_one_mat(3) index_smult_mat(2,3) j)
      have "?reduce_below = four_block_mat A'_UL A'_UR A'_DL A'_DR" using fbm_R ..
      also have "... $$ (i+1,j+1) = (if i+1 < dim_row A'_UL then if j+1 < dim_col A'_UL 
              then A'_UL $$ (i+1, j+1) else A'_UR $$ (i+1, j+1 - dim_col A'_UL)
              else if j+1 < dim_col A'_UL then A'_DL $$ (i+1 - dim_row A'_UL, j+1)
              else A'_DR $$ (i+1 - dim_row A'_UL, j+1 - dim_col A'_UL))"
        by (rule index_mat_four_block, insert i j A'_UL A'_DR dr dc, auto)
      also have "... = A'_DR $$ (i,j)" using A'_UL by auto
      finally have 2: "?reduce_below $$ (i+1,j+1) = A'_DR $$ (i,j)" .
      show ?thesis 
      proof (cases "xs = []")
        case True note xs_empty = True
        have i1_m: "i + 1  m" 
          using False less_add_one by blast
        have j1n: "j+1<n"
          using jn1 less_diff_conv by blast
        have i1_mn: "i+1<m + n"
          using i i_ge_m
          by (metis A'_DR carrier_matD(1) dr less_diff_conv sub_PreHNF sub_PreHNF')
        have "?reduce_below = reduce_abs 0 m D M"
          unfolding non_zero_positions_xs_m xs_empty M_def by auto
        also have "... $$ (i+1,j+1) = M $$ (i+1, j+1)"
          by (rule reduce_preserves[OF M j1n _ i1_m _ i1_mn], insert M_def mk_A'_not0, auto)         
        also have "... = (D m 1m n) $$ ((i+1)-m, j+1)"
        proof (cases "A $$ (0,0) = 0")
          case True
          let ?S = "(swaprows 0 m A)"
          have S: "?S  carrier_mat (m+n) n" using A by auto
          have Si10: "?S $$ (i+1,0) = 0"
          proof -
            have "?S $$ (i+1,0) = A $$ (i+1,0)" using i1_m n0 i1_mn S by auto
            also have "... = (D m 1m n) $$ (i+1 - m,0)"
              by (smt A_def A'' A i_ge_m append_rows_def carrier_matD diff_add_inverse2 i1_mn 
                  index_mat_four_block less_imp_diff_less n0)
            also have "... = 0" using i_ge_m n0 i1_mn by auto
            finally show ?thesis .
          qed
          have "M $$ (i+1, j+1) = (make_first_column_positive ?S) $$ (i+1,j+1)"
            by (simp add: A'_def M_def True non_zero_positions_xs_m xs_empty)
          also have "... = (if ?S $$ (i+1,0) < 0 then - ?S $$ (i+1,j+1) else ?S $$ (i+1,j+1))" 
            unfolding make_first_column_positive.simps using S i1_mn j1n by auto
          also have "... = ?S $$ (i+1,j+1)" using Si10 by auto
          also have "... = A $$ (i+1,j+1)" using i1_m n0 i1_mn S jn1 by auto
          also have "... = (D m 1m n) $$ (i+1 - m,j+1)"
            by (smt A_def A'' A i_ge_m append_rows_def carrier_matD i1_mn index_mat_four_block(1,3)
                index_one_mat(2) index_smult_mat(2) index_zero_mat(2) j1n less_imp_diff_less add_diff_cancel_right')
          finally show ?thesis .
        next
          case False         
          have Ai10: "A $$ (i+1,0) = 0"
          proof -
            have "A $$ (i+1,0) = (D m 1m n) $$ (i+1 - m,0)"
              by (smt A_def A'' A i_ge_m append_rows_def carrier_matD diff_add_inverse2 i1_mn 
                  index_mat_four_block less_imp_diff_less n0)
            also have "... = 0" using i_ge_m n0 i1_mn by auto
            finally show ?thesis .
          qed          
          have "M $$ (i+1, j+1) = (make_first_column_positive A) $$ (i+1,j+1)"
            by (simp add: A'_def M_def False True non_zero_positions_xs_m)
          also have "... = (if A $$ (i+1,0) < 0 then - A $$ (i+1,j+1) else A $$ (i+1,j+1))" 
            unfolding make_first_column_positive.simps using A i1_mn j1n by auto
          also have "... = A $$ (i+1,j+1)" using Ai10 by auto
          also have "... = (D m 1m n) $$ (i+1 - m,j+1)"
            by (smt A_def A'' A i_ge_m append_rows_def carrier_matD i1_mn index_mat_four_block(1,3)
                index_one_mat(2) index_smult_mat(2) index_zero_mat(2) j1n less_imp_diff_less add_diff_cancel_right')
          finally show ?thesis .
        qed
        also have "... = D * (1m n) $$ ((i+1)-m, j+1)"
          by (rule index_smult_mat, insert i jn1 A'_DR False dr, auto)            
        also have "... = D *(1m (n - 1)) $$ (i-m,j)" using dc dr i j A'_DR i_ge_m
          by (smt Nat.add_diff_assoc2 carrier_matD(1) index_one_mat(1) jn1 less_diff_conv 
              linorder_not_less add_diff_cancel_right' add_diff_cancel_right' add_diff_cancel_left')
        also have "... = (D m 1m (n - 1)) $$ (i-m,j)"
          by (rule index_smult_mat[symmetric], insert i jn1 A'_DR False dr, auto)
        finally show ?thesis using 1 2 by auto
      next
        case False     
      have "?reduce_below $$ (i+1, j+1) = M $$ (i+1, j+1)"
      proof (unfold non_zero_positions_xs_m M_def,
          rule reduce_below_abs_preserves_case_m[OF M' m0 _ M_M'D mk_A'_not0 m_le_n _ d_xs all_less_m _ _ _ D0])            
        show "j + 1 < n" using jn1 by auto
        show "i + 1  set xs" using all_less_m i_ge_m non_zero_positions_xs_m by auto
        show "i + 1  0" by auto
        show " i + 1 < m + n" using i_ge_m i dr A'_DR by auto
        show " i + 1  m" using i_ge_m by auto
      qed (insert False)
      also have "... = (?M' @r D m 1m n) $$ (i+1, j+1)" unfolding M_def using False M_M'D by argo
      also have "... = (D m 1m n) $$ ((i+1)-m, j+1)"
      proof -
        have f1: "1 + j < n"
          by (metis Groups.add_ac(2) jn1 less_diff_conv)
        have f2: "n. ¬ n + i < m"
          by (meson i_ge_m linorder_not_less nat_SN.compat not_add_less2)
        have "i < m + (n - 1)"
          by (metis (no_types) A'_DR carrier_matD(1) dr i)
        then have "1 + i < m + n"
          using f1 by linarith
        then show ?thesis
          using f2 f1 by (metis (no_types) Groups.add_ac(2) M' append_rows_def carrier_matD(1) 
              dim_col_mat(1) index_mat_four_block(1) index_one_mat(2) index_smult_mat(2) 
              index_zero_mat(2,3) mat_of_rows_def nat_arith.rule0)
      qed
      also have "... = D * (1m n) $$ ((i+1)-m, j+1)"
        by (rule index_smult_mat, insert i jn1 A'_DR False dr, auto)            
      also have "... = D *(1m (n - 1)) $$ (i-m,j)" using dc dr i j A'_DR i_ge_m
        by (smt Nat.add_diff_assoc2 carrier_matD(1) index_one_mat(1) jn1 less_diff_conv 
            linorder_not_less add_diff_cancel_right' add_diff_cancel_left')
      also have "... = (D m 1m (n - 1)) $$ (i-m,j)"
        by (rule index_smult_mat[symmetric], insert i jn1 A'_DR False dr, auto)
      finally have 3: "?reduce_below $$ (i+1,j+1) = (D m 1m (n - 1)) $$ (i-m,j)" .            
      show ?thesis using 1 2 3 by presburger
    qed              
  qed
qed
  let ?A'_DR_n = "mat_of_rows (n - 1) (map (Matrix.row A'_DR) [0..<n - 1])"
  have hyp: "P. Pcarrier_mat (m + (n-1)) (m + (n-1))  invertible_mat P  sub_PreHNF = P * A'_DR 
   echelon_form_JNF sub_PreHNF" 
  proof (cases "2  n - 1")
    case True
    show ?thesis
      by (unfold sub_PreHNF_def, rule "1.hyps"[OF _ _ _ non_zero_positions_def A'_def _ _ _ _ _])
         (insert A n D0 m_le_n True A'DR_A'DR_m_D A A'_split abs_flag, auto)
  next
    case False
    have "P. Pcarrier_mat (m + (n-1)) (m + (n-1))  invertible_mat P  sub_PreHNF = P * A'_DR"
      by (unfold sub_PreHNF_def, rule FindPreHNF_invertible_mat_mx2
          [OF A'DR_A'DR_m_D A'_DR_m _ _ D0 _])
          (insert False m_le_n n0 m0 "1"(4), auto)
    moreover have "echelon_form_JNF sub_PreHNF" unfolding sub_PreHNF_def 
      by (rule FindPreHNF_echelon_form_mx1[OF A'DR_A'DR_m_D A'_DR_m _ D0 _],
          insert False n0 m_le_n, auto) 
    ultimately show ?thesis by simp
  qed  
  from this obtain P where P: "P  carrier_mat (m + (n - 1)) (m + (n - 1))"
    and inv_P: "invertible_mat P" and sub_PreHNF_P_A'_DR: "sub_PreHNF = P * A'_DR" by blast
  define P' where "P' = (four_block_mat (1m 1) (0m 1 (m+(n-1))) (0m (m+(n-1)) 1) P)"
  have P': "P'  carrier_mat (m+n) (m+n)" 
  proof -
    have "P'  carrier_mat (1 + (m+(n-1))) (1 + (m+(n-1))) "
      unfolding P'_def by (rule four_block_carrier_mat[OF _ P], simp) 
    thus ?thesis using n by auto
  qed
  have inv_P': "invertible_mat P'" 
    unfolding P'_def by (rule invertible_mat_four_block_mat_lower_right[OF P inv_P])
  have dr_A2: "dim_row A  2" using A m0 n by auto
  have dc_A2: "dim_col A  2" using n A by blast
  have *: "(dim_col A = 0) = False" using dc_A2 by auto
  have FindPreHNF_as_fbm: "FindPreHNF abs_flag D A = four_block_mat A'_UL A'_UR A'_DL sub_PreHNF" 
    unfolding FindPreHNF.simps[of abs_flag D A] using A'_split mn n A dr_A2 dc_A2 abs_flag
    unfolding Let_def sub_PreHNF_def M_def A'_def non_zero_positions_def *    
    by (smt (z3) linorder_not_less split_conv)
  also have "... = P' * (reduce_below_abs 0 non_zero_positions D M)"
  proof -
    have "P' * (reduce_below_abs 0 non_zero_positions D M) 
      = four_block_mat (1m 1) (0m 1 (m + (n - 1))) (0m (m + (n - 1)) 1) P 
      * four_block_mat A'_UL A'_UR A'_DL A'_DR"
      unfolding P'_def fbm_R[unfolded M_def[symmetric], symmetric] ..
    also have "... = four_block_mat 
            ((1m 1) * A'_UL + (0m 1 (m + (n - 1)) * A'_DL)) 
            ((1m 1) * A'_UR + (0m 1 (m + (n - 1))) * A'_DR) 
            ((0m (m + (n - 1)) 1) * A'_UL + P * A'_DL) 
            ((0m (m + (n - 1)) 1) * A'_UR + P * A'_DR)" 
      by (rule mult_four_block_mat[OF _ _ _ P A'_UL A'_UR A'_DL A'_DR], auto)
    also have "... = four_block_mat A'_UL A'_UR (P * A'_DL) (P * A'_DR)"
      by (rule cong_four_block_mat, insert A'_UL A'_UR A'_DL A'_DR P, auto)
    also have "... = four_block_mat A'_UL A'_UR (0m (m + (n - 1)) 1) sub_PreHNF"
      unfolding A'_DL0 sub_PreHNF_P_A'_DR using P by simp
    also have "... = four_block_mat A'_UL A'_UR A'_DL sub_PreHNF"
      unfolding A'_DL0 by simp
    finally show ?thesis ..
  qed
  finally have Find_P'_reduceM: "FindPreHNF abs_flag D A =  P' * (reduce_below_abs 0 non_zero_positions D M)" .
  have "Q. invertible_mat Q  Q  carrier_mat (m + n) (m + n) 
     reduce_below_abs 0 (xs @ [m]) D M = Q * M"
  proof (cases "xs = []")
    case True note xs_empty = True
    have rw: "reduce_below_abs 0 (xs @ [m]) D M = reduce_abs 0 m D M" using True by auto
    obtain p q u v d where pquvd: "(p, q, u, v, d) = euclid_ext2 (M $$ (0, 0)) (M $$ (m, 0))"
      by (simp add: euclid_ext2_def)
    have "P. invertible_mat P  P  carrier_mat (m + n) (m + n)  reduce_abs 0 m D M = P * M"  
    proof (rule reduce_abs_invertible_mat_case_m[OF _ _ m0 _ _ _ _ m_le_n n0 pquvd])
          show "M $$ (0, 0)  0" 
            using M_def mk_A'_not0 by blast
          define M' where  "M' = mat_of_rows n (map (Matrix.row M) [0..<m])"
          define M'' where "M'' = mat_of_rows n (map (Matrix.row M) [m..<m+n])"
          define A2 where "A2 = Matrix.mat (dim_row M) (dim_col M)
          (λ(i, k). if i = 0 then p * M $$ (0, k) + q * M $$ (m, k) 
                    else if i = m then u * M $$ (0, k) + v * M $$ (m, k)
                    else M $$ (i, k))"
          show M_M'_M'': "M = M' @r M''" unfolding M'_def M''_def            
            by (metis M append_rows_split carrier_matD le_add1)
          show M': "M'  carrier_mat m n" unfolding M'_def by fastforce
          show M'': "M''  carrier_mat n n" unfolding M''_def by fastforce
          show "0  m" using m0 by simp
          show "A2 = Matrix.mat (dim_row M) (dim_col M)
          (λ(i, k). if i = 0 then p * M $$ (0, k) + q * M $$ (m, k) 
                    else if i = m then u * M $$ (0, k) + v * M $$ (m, k)
                    else M $$ (i, k))"
            (is "_ = ?rhs") using A A2_def by auto
          define xs' where "xs' =  filter (λi. abs (A2 $$ (0,i)) > D) [0..<n]"
          define ys' where  "ys' = filter (λi. abs (A2 $$ (m,i)) > D) [0..<n]"
          show "xs' = filter (λi. abs (A2 $$ (0,i)) > D) [0..<n]" unfolding xs'_def by auto
          show "ys' = filter (λi. abs (A2 $$ (m,i)) > D) [0..<n]" unfolding ys'_def by auto
          have M''D: "(M'' $$ (j, j) = D)  (j'{0..<n}-{j}. M'' $$ (j, j') = 0)"
            if jn: "j<n" and j0: "j>0" for j
          proof -
            have Ajm0: "A $$ (j+m,0) = 0"
            proof -
              have "A $$ (j+m,0) = (D m 1m n) $$ (j+m-m,0)"
                by (smt "1"(2) "1"(3) M M' M'' M_M'_M'' add.commute append_rows_def carrier_matD
                    diff_add_inverse2 index_mat_four_block index_one_mat(2) index_smult_mat(2)
                    le_add2 less_diff_conv2 n0 not_add_less2 that(1))
              also have "... = 0" using jn j0 by auto
              finally show ?thesis .
            qed
            have "M'' $$ (j, i) = (D m 1m n) $$ (j,i)" if i_n: "i<n" for i
            proof (cases "A$$(0,0) = 0")
              case True 
              have "M'' $$ (j, i) = make_first_column_positive (swaprows 0 m A) $$ (j+m,i)"                
                by (smt A'_def Groups.add_ac(2) M' M'' M_M'_M'' M_def True append.simps(1) 
                    append_rows_nth3 diff_add_inverse2 jn le_add2 local.non_zero_positions_xs_m
                    nat_add_left_cancel_less nth_Cons_0 that xs_empty)
              also have "... = A $$ (j+m,i)" using A jn j0 i_n Ajm0 by auto
              also have "... = (D m 1m n) $$ (j,i)"
                by (smt A Groups.add_ac(2) add_mono_thms_linordered_field(1) append_rows_def A_def A'' i_n
                    carrier_matD index_mat_four_block(1,2) add_diff_cancel_right' not_add_less2 jn trans_less_add1)
              finally show ?thesis .            
            next
              case False
              have "A' = A" unfolding A'_def non_zero_positions_xs_m using False True by auto
              hence "M'' $$ (j, i) = make_first_column_positive A $$ (j+m,i)"                
                by (smt m_le_n M' M'' M_M'_M'' M_def append_rows_nth2 jn nat_SN.compat that)                
              also have "... = A $$ (j+m,i)" using A jn j0 i_n Ajm0 by auto
              also have "... = (D m 1m n) $$ (j,i)"
                by (smt A Groups.add_ac(2) add_mono_thms_linordered_field(1) append_rows_def A_def A'' i_n
                    carrier_matD index_mat_four_block(1,2) add_diff_cancel_right' not_add_less2 jn trans_less_add1)
              finally show ?thesis .
            qed                           
            thus ?thesis using jn j0 by auto
          qed
          have Am0D: "A$$(m,0) = D"
          proof -
            have "A$$(m,0) = (D m 1m n) $$ (m-m,0)"
              by (smt "1"(2) "1"(3) M M' M'' M_M'_M'' append_rows_def carrier_matD
                  diff_less_mono2 diff_self_eq_0 index_mat_four_block index_one_mat(2) 
                  index_smult_mat(2) less_add_same_cancel1 n0 semiring_norm(137))
            also have "... = D" using m0 n0 by auto
            finally show ?thesis .
          qed
          hence S00D: "(swaprows 0 m A) $$ (0,0) = D" using n0 m0 A by auto
          have Sm00: "(swaprows 0 m A) $$ (m,0) = A$$(0,0)" using n0 m0 A by auto
          have M00D: "M $$ (0, 0) = D" if A00: "A$$(0,0) = 0"
          proof -
            have "M $$ (0,0) = (make_first_column_positive (swaprows 0 m A)) $$ (0,0)"
              unfolding M_def A'_def using A00
              by (simp add: True non_zero_positions_xs_m)
            also have "... = (if (swaprows 0 m A) $$ (0,0) < 0 then - (swaprows 0 m A) $$(0,0)
                              else (swaprows 0 m A) $$(0,0))"
              unfolding make_first_column_positive.simps using m0 n0 A by auto
            also have "... = (swaprows 0 m A) $$(0,0)" using S00D D0 by auto
            also have "... = D" using S00D by auto
            finally show ?thesis .
          qed
          have Mm00: "M $$ (m, 0) = 0" if A00: "A$$(0,0) = 0"
          proof -
            have "M $$ (m,0) = (make_first_column_positive (swaprows 0 m A)) $$ (m,0)"
              unfolding M_def A'_def using A00
              by (simp add: True non_zero_positions_xs_m)
            also have "... = (if (swaprows 0 m A) $$ (m,0) < 0 then - (swaprows 0 m A) $$(m,0)
                              else (swaprows 0 m A) $$(m,0))"
              unfolding make_first_column_positive.simps using m0 n0 A by auto
            also have "... = (swaprows 0 m A) $$(m,0)" using Sm00 A00 D0 by auto
            also have "... = 0" using Sm00 A00 by auto
            finally show ?thesis .
          qed
          have M000: "M $$ (0, 0) = abs (A$$(0,0))" if A00: "A$$(0,0)  0"
          proof -
            have "M $$ (0,0) = (make_first_column_positive A) $$ (0,0)"
              unfolding M_def A'_def using A00
              by (simp add: True non_zero_positions_xs_m)
            also have "... = (if A $$ (0,0) < 0 then - A $$(0,0)
                              else A $$(0,0))"
              unfolding make_first_column_positive.simps using m0 n0 A by auto
            also have "... = abs (A$$(0,0))" using Sm00 A00 by auto
            finally show ?thesis .
          qed
          have Mm0D: "M $$ (m, 0) = D" if A00: "A $$ (0,0)  0"
          proof -
            have "M $$ (m,0) = (make_first_column_positive A) $$ (m,0)"
              unfolding M_def A'_def using A00
              by (simp add: True non_zero_positions_xs_m)
            also have "... = (if A $$ (m,0) < 0 then - A $$(m,0)
                              else A $$(m,0))"
              unfolding make_first_column_positive.simps using m0 n0 A by auto
            also have "... = A $$(m,0)" using S00D D0 Am0D by auto
            also have "... = D" using Am0D D0 by auto
            finally show ?thesis .
          qed
          have "0  set xs'"
          proof -
            have "A2 $$ (0,0) = p * M $$ (0, 0) + q * M $$ (m, 0)" 
              using A A2_def n0 M by auto
            also have "... = gcd (M $$ (0, 0)) (M $$ (m, 0))"
              by (metis euclid_ext2_works(1,2) pquvd)
            also have "abs ...  D" using M00D Mm00 M000 Mm0D using gcd_0_int D0 by fastforce
            finally have "abs (A2 $$ (0,0))  D" .
            thus ?thesis unfolding xs'_def using D0 by auto
          qed
          thus "jset xs'. j<n  (M'' $$ (j, j) = D)  (j'{0..<n}-{j}. M'' $$ (j, j') = 0)"  
            using M''D xs'_def by auto
          have "0  set ys'"
          proof -
            have "A2 $$ (m,0) = u * M $$ (0, 0) + v * M $$ (m, 0)"
              using A A2_def n0 m0 M by auto
            also have "... = - M $$ (m, 0) div gcd (M $$ (0, 0)) (M $$ (m, 0)) * M $$ (0, 0) 
                + M $$ (0, 0) div gcd (M $$ (0, 0)) (M $$ (m, 0)) * M $$ (m, 0) "
              by (simp add: euclid_ext2_works[OF pquvd[symmetric]])
            also have "... = 0" using M00D Mm00 M000 Mm0D
              by (smt dvd_div_mult_self euclid_ext2_works(3) euclid_ext2_works(5)
                  more_arith_simps(11) mult.commute mult_minus_left pquvd semiring_gcd_class.gcd_dvd1)
            finally have "A2 $$ (m,0) = 0" .
            thus ?thesis unfolding ys'_def using D0 by auto
          qed
          thus "jset ys'. j<n  (M'' $$ (j, j) = D)  (j'{0..<n}-{j}. M'' $$ (j, j') = 0)"
            using M''D ys'_def by auto   
        qed (insert D0)
        then show ?thesis using rw by auto
  next
    case False
    show ?thesis
      by (unfold M_def, rule reduce_below_abs_invertible_mat_case_m[OF M' m0 n0 M_M'D[OF False] 
          mk_A'_not0 m_le_n d_xs all_less_m D0])
  qed
   
  from this obtain Q where inv_Q: "invertible_mat Q" and Q: "Q  carrier_mat (m + n) (m + n)"
    and reduce_QM: "reduce_below_abs 0 (xs @ [m]) D M = Q * M" by blast
  have "R. invertible_mat R 
     R  carrier_mat (dim_row A') (dim_row A')  M = R * A'"
    by (unfold M_def, rule make_first_column_positive_invertible)
  from this obtain R where inv_R: "invertible_mat R"
    and R: "R  carrier_mat (dim_row A') (dim_row A')" and M_RA': "M = R * A'" by blast
  have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P  A' = P * A" 
    by (rule A'_swaprows_invertible_mat[OF A A'_def non_zero_positions_def],
        insert non_zero_positions_xs_m n m0, auto)
  from this obtain S where inv_S: "invertible_mat S"
   and S: "S  carrier_mat (dim_row A) (dim_row A)" and A'_SA: "A' = S * A" 
    using A by auto
  have "(P'*Q*R*S)  carrier_mat (m+n) (m+n)" using P' Q R S A' A by auto
  moreover have "FindPreHNF abs_flag D A = (P'*Q*R*S) * A" using Find_P'_reduceM reduce_QM 
    unfolding  M_RA' A'_SA M_def
    by (smt A' A'_SA P' Q R S assoc_mult_mat carrier_matD carrier_mat_triv index_mult_mat(2,3) 
        non_zero_positions_xs_m)
  moreover have "invertible_mat (P'*Q*R*S)" using inv_P' inv_Q inv_R inv_S using P' Q R S A' A 
    by (metis carrier_matD carrier_mat_triv index_mult_mat(2,3) invertible_mult_JNF)
  ultimately have exists_inv: "P. P  carrier_mat (m + n) (m + n)  invertible_mat P 
     FindPreHNF abs_flag D A = P * A" by blast
  moreover have "echelon_form_JNF (FindPreHNF abs_flag D A)" 
  proof (rule echelon_form_four_block_mat[OF A'_UL A'_UR sub_PreHNF'   ])
    show "FindPreHNF abs_flag D A = four_block_mat A'_UL A'_UR (0m (m + n - 1) 1) sub_PreHNF" 
      using A'_DL0 FindPreHNF_as_fbm sub_PreHNF sub_PreHNF' by auto
    have "A'_UL $$ (0, 0) = ?R $$ (0,0)"
      by (metis (mono_tags, lifting) A A'_DR A'_UL Find_P'_reduceM M_def 
          ‹FindPreHNF abs_flag D A = P' * Q * R * S * A add_Suc_right add_sign_intros(2) carrier_matD fbm_R
          index_mat_four_block(1,3) index_mult_mat(3) m0 n0 plus_1_eq_Suc
          zero_less_one_class.zero_less_one)
    also have "...  0"
    proof (cases "xs=[]")
      case True
      have "?R $$ (0,0) = reduce_abs 0 m D M $$ (0,0)"
        unfolding non_zero_positions_xs_m True M_def by simp
      also have "...  0"
        by (metis D_not0 M M_def add_pos_pos less_add_same_cancel1 m0 mk_A'_not0 n0 reduce_not0)
      finally show ?thesis .
    next
      case False
      show ?thesis
        by (unfold non_zero_positions_xs_m,
          rule reduce_below_abs_not0_case_m[OF M' m0 n0 M_M'D[OF False] mk_A'_not0 m_le_n all_less_m D_not0])     
    qed       
    finally show "A'_UL $$ (0, 0)  0" .
  qed (insert mn n hyp, auto)
  ultimately show ?thesis by blast
  next
    case False
      hence A'_split: "(A'_UL, A'_UR, A'_DL, A'_DR) 
    = split_block (reduce_below 0 non_zero_positions D (make_first_column_positive A')) 1 1"   using A'_split by auto
    let ?R = "reduce_below 0 non_zero_positions D (make_first_column_positive A')"
   have fbm_R: "four_block_mat A'_UL A'_UR A'_DL A'_DR 
     = reduce_below 0 non_zero_positions D (make_first_column_positive A')"
    by (rule split_block(5)[symmetric, OF A'_split[symmetric], of "m+n-1" "n-1"], insert A' n, auto)
  have A'_DL0: "A'_DL = (0m (m + (n - 1)) 1)"   
  proof (rule eq_matI)
    show "dim_row A'_DL = dim_row (0m (m + (n - 1)) 1)"
      and "dim_col A'_DL = dim_col (0m (m + (n - 1)) 1)" using A'_DL by auto    
    fix i j assume i: "i < dim_row (0m (m + (n - 1)) 1)" and j: "j < dim_col (0m (m + (n - 1)) 1)"
    have j0: "j=0" using j by auto
    have "0 = ?R $$ (i+1,j)"
    proof (unfold M_def non_zero_positions_xs_m j0, 
        rule reduce_below_0_case_m_make_first_column_positive[symmetric,
          OF A'' m0 n0 A_def m_le_n _  d_xs all_less_m _ _ D0 _ ])
      show "A' = (if A $$ (0, 0)  0 then A else let i = (xs @ [m]) ! 0 in swaprows 0 i A)"
        using A'_def non_zero_positions_def non_zero_positions_xs_m by presburger
      show "xs @ [m] = filter (λi. A $$ (i, 0)  0) [1..<dim_row A]"
        using A'_def non_zero_positions_def non_zero_positions_xs_m by presburger
    qed (insert i n0, auto)
    also have "... = four_block_mat A'_UL A'_UR A'_DL A'_DR $$ (i+1,j)" unfolding fbm_R ..
    also have "... = (if i+1 < dim_row A'_UL then if j < dim_col A'_UL 
            then A'_UL $$ (i+1, j) else A'_UR $$ (i+1, j - dim_col A'_UL)
            else if j < dim_col A'_UL then A'_DL $$ (i+1 - dim_row A'_UL, j)
            else A'_DR $$ (i+1 - dim_row A'_UL, j - dim_col A'_UL))"
      by (rule index_mat_four_block, insert A'_UL A'_DR i j, auto)
    also have "... = A'_DL $$ (i, j)" using A'_UL A'_UR i j by auto
    finally show "A'_DL $$ (i, j) = 0m (m + (n - 1)) 1 $$ (i, j)" using i j by auto
  qed

  let ?A'_DR_m = "mat_of_rows (n-1) [Matrix.row A'_DR i. i  [0..<m]]"
  have A'_DR_m: "?A'_DR_m  carrier_mat m (n-1)" by auto
  have A'DR_A'DR_m_D: "A'_DR = ?A'_DR_m @r D m 1m (n - 1)"
  proof (rule eq_matI)
    show dr: "dim_row A'_DR = dim_row (?A'_DR_m @r D m 1m (n - 1))" 
      by (metis A'_DR A'_DR_m append_rows_def carrier_matD(1) index_mat_four_block(2) 
          index_one_mat(2) index_smult_mat(2) index_zero_mat(2))
    show dc: "dim_col A'_DR = dim_col (?A'_DR_m @r D m 1m (n - 1))"
      by (metis A'_DR A'_DR_m add.comm_neutral append_rows_def
          carrier_matD(2) index_mat_four_block(3) index_zero_mat(3))  
    fix i j assume i: "i < dim_row(?A'_DR_m @r D m 1m (n - 1))"
      and j: "j<dim_col (?A'_DR_m @r D m 1m (n - 1))"
    have jn1: "j<n-1" using dc j A'_DR by auto
    show "A'_DR $$ (i,j) = (?A'_DR_m @r D m 1m (n - 1)) $$ (i,j)"
    proof (cases "i<m")
      case True
      have "A'_DR $$ (i,j) = ?A'_DR_m $$ (i,j)"
        by (metis A'_DR A'_DR_m True dc carrier_matD(1) carrier_matD(2) j le_add1 
            map_first_rows_index mat_of_rows_carrier(2) mat_of_rows_index)
      also have "... = (?A'_DR_m @r D m 1m (n - 1)) $$ (i,j)"
        by (metis (mono_tags, lifting) A'_DR A'_DR_m True append_rows_def 
            carrier_matD dc i index_mat_four_block j)
      finally show ?thesis .
    next
      case False note i_ge_m = False
      let ?reduce_below = "reduce_below 0 non_zero_positions D (make_first_column_positive A')"
      have 1: "(?A'_DR_m @r D m 1m (n - 1)) $$ (i,j) = (D m 1m (n - 1)) $$ (i-m,j)"
        by (smt A'_DR A'_DR_m False append_rows_nth carrier_matD carrier_mat_triv dc dr i
            index_one_mat(2) index_one_mat(3) index_smult_mat(2,3) j)
      have "?reduce_below = four_block_mat A'_UL A'_UR A'_DL A'_DR" using fbm_R ..
      also have "... $$ (i+1,j+1) = (if i+1 < dim_row A'_UL then if j+1 < dim_col A'_UL 
              then A'_UL $$ (i+1, j+1) else A'_UR $$ (i+1, j+1 - dim_col A'_UL)
              else if j+1 < dim_col A'_UL then A'_DL $$ (i+1 - dim_row A'_UL, j+1)
              else A'_DR $$ (i+1 - dim_row A'_UL, j+1 - dim_col A'_UL))"
        by (rule index_mat_four_block, insert i j A'_UL A'_DR dr dc, auto)
      also have "... = A'_DR $$ (i,j)" using A'_UL by auto
      finally have 2: "?reduce_below $$ (i+1,j+1) = A'_DR $$ (i,j)" .
      show ?thesis 
      proof (cases "xs = []")
        case True note xs_empty = True
        have i1_m: "i + 1  m" 
          using False less_add_one by blast
        have j1n: "j+1<n"
          using jn1 less_diff_conv by blast
        have i1_mn: "i+1<m + n"
          using i i_ge_m
          by (metis A'_DR carrier_matD(1) dr less_diff_conv sub_PreHNF sub_PreHNF')
        have "?reduce_below = reduce 0 m D M"
          unfolding non_zero_positions_xs_m xs_empty M_def by auto
        also have "... $$ (i+1,j+1) = M $$ (i+1, j+1)"
          by (rule reduce_preserves[OF M j1n _ i1_m _ i1_mn], insert M_def mk_A'_not0, auto)         
        also have "... = (D m 1m n) $$ ((i+1)-m, j+1)"
        proof (cases "A $$ (0,0) = 0")
          case True
          let ?S = "(swaprows 0 m A)"
          have S: "?S  carrier_mat (m+n) n" using A by auto
          have Si10: "?S $$ (i+1,0) = 0"
          proof -
            have "?S $$ (i+1,0) = A $$ (i+1,0)" using i1_m n0 i1_mn S by auto
            also have "... = (D m 1m n) $$ (i+1 - m,0)"
              by (smt A_def A'' A i_ge_m append_rows_def carrier_matD diff_add_inverse2 i1_mn 
                  index_mat_four_block less_imp_diff_less n0)
            also have "... = 0" using i_ge_m n0 i1_mn by auto
            finally show ?thesis .
          qed
          have "M $$ (i+1, j+1) = (make_first_column_positive ?S) $$ (i+1,j+1)"
            by (simp add: A'_def M_def True non_zero_positions_xs_m xs_empty)
          also have "... = (if ?S $$ (i+1,0) < 0 then - ?S $$ (i+1,j+1) else ?S $$ (i+1,j+1))" 
            unfolding make_first_column_positive.simps using S i1_mn j1n by auto
          also have "... = ?S $$ (i+1,j+1)" using Si10 by auto
          also have "... = A $$ (i+1,j+1)" using i1_m n0 i1_mn S jn1 by auto
          also have "... = (D m 1m n) $$ (i+1 - m,j+1)"
            by (smt A_def A'' A i_ge_m append_rows_def carrier_matD i1_mn index_mat_four_block(1,3)
                index_one_mat(2) index_smult_mat(2) index_zero_mat(2) j1n less_imp_diff_less add_diff_cancel_right')
          finally show ?thesis .
        next
          case False         
          have Ai10: "A $$ (i+1,0) = 0"
          proof -
            have "A $$ (i+1,0) = (D m 1m n) $$ (i+1 - m,0)"
              by (smt A_def A'' A i_ge_m append_rows_def carrier_matD diff_add_inverse2 i1_mn 
                  index_mat_four_block less_imp_diff_less n0)
            also have "... = 0" using i_ge_m n0 i1_mn by auto
            finally show ?thesis .
          qed          
          have "M $$ (i+1, j+1) = (make_first_column_positive A) $$ (i+1,j+1)"
            by (simp add: A'_def M_def False True non_zero_positions_xs_m)
          also have "... = (if A $$ (i+1,0) < 0 then - A $$ (i+1,j+1) else A $$ (i+1,j+1))" 
            unfolding make_first_column_positive.simps using A i1_mn j1n by auto
          also have "... = A $$ (i+1,j+1)" using Ai10 by auto
          also have "... = (D m 1m n) $$ (i+1 - m,j+1)"
            by (smt A_def A'' A i_ge_m append_rows_def carrier_matD i1_mn index_mat_four_block(1,3)
                index_one_mat(2) index_smult_mat(2) index_zero_mat(2) j1n less_imp_diff_less add_diff_cancel_right')
          finally show ?thesis .
        qed
        also have "... = D * (1m n) $$ ((i+1)-m, j+1)"
          by (rule index_smult_mat, insert i jn1 A'_DR False dr, auto)            
        also have "... = D *(1m (n - 1)) $$ (i-m,j)" using dc dr i j A'_DR i_ge_m
          by (smt Nat.add_diff_assoc2 carrier_matD(1) index_one_mat(1) jn1 less_diff_conv 
              linorder_not_less add_diff_cancel_right' add_diff_cancel_right' add_diff_cancel_left')
        also have "... = (D m 1m (n - 1)) $$ (i-m,j)"
          by (rule index_smult_mat[symmetric], insert i jn1 A'_DR False dr, auto)
        finally show ?thesis using 1 2 by auto
      next
        case False     
      have "?reduce_below $$ (i+1, j+1) = M $$ (i+1, j+1)"
      proof (unfold non_zero_positions_xs_m M_def,
          rule reduce_below_preserves_case_m[OF M' m0 _ M_M'D mk_A'_not0 m_le_n _ d_xs all_less_m _ _ _ D0])            
        show "j + 1 < n" using jn1 by auto
        show "i + 1  set xs" using all_less_m i_ge_m non_zero_positions_xs_m by auto
        show "i + 1  0" by auto
        show " i + 1 < m + n" using i_ge_m i dr A'_DR by auto
        show " i + 1  m" using i_ge_m by auto
      qed (insert False)
      also have "... = (?M' @r D m 1m n) $$ (i+1, j+1)" unfolding M_def using False M_M'D by argo
      also have "... = (D m 1m n) $$ ((i+1)-m, j+1)"
      proof -
        have f1: "1 + j < n"
          by (metis Groups.add_ac(2) jn1 less_diff_conv)
        have f2: "n. ¬ n + i < m"
          by (meson i_ge_m linorder_not_less nat_SN.compat not_add_less2)
        have "i < m + (n - 1)"
          by (metis (no_types) A'_DR carrier_matD(1) dr i)
        then have "1 + i < m + n"
          using f1 by linarith
        then show ?thesis
          using f2 f1 by (metis (no_types) Groups.add_ac(2) M' append_rows_def carrier_matD(1) 
              dim_col_mat(1) index_mat_four_block(1) index_one_mat(2) index_smult_mat(2) 
              index_zero_mat(2,3) mat_of_rows_def nat_arith.rule0)
      qed
      also have "... = D * (1m n) $$ ((i+1)-m, j+1)"
        by (rule index_smult_mat, insert i jn1 A'_DR False dr, auto)            
      also have "... = D *(1m (n - 1)) $$ (i-m,j)" using dc dr i j A'_DR i_ge_m
        by (smt Nat.add_diff_assoc2 carrier_matD(1) index_one_mat(1) jn1 less_diff_conv 
            linorder_not_less add_diff_cancel_right' add_diff_cancel_left')
      also have "... = (D m 1m (n - 1)) $$ (i-m,j)"
        by (rule index_smult_mat[symmetric], insert i jn1 A'_DR False dr, auto)
      finally have 3: "?reduce_below $$ (i+1,j+1) = (D m 1m (n - 1)) $$ (i-m,j)" .            
      show ?thesis using 1 2 3 by presburger
    qed              
  qed
qed
  let ?A'_DR_n = "mat_of_rows (n - 1) (map (Matrix.row A'_DR) [0..<n - 1])"
  have hyp: "P. Pcarrier_mat (m + (n-1)) (m + (n-1))  invertible_mat P  sub_PreHNF = P * A'_DR 
   echelon_form_JNF sub_PreHNF" 
  proof (cases "2  n - 1")
    case True
    show ?thesis
      by (unfold sub_PreHNF_def, rule "1.hyps"[OF _ _ _ non_zero_positions_def A'_def _ _ _ _ _])
         (insert A n D0 m_le_n True A'DR_A'DR_m_D A A'_split False, auto)
  next
    case False
    have "P. Pcarrier_mat (m + (n-1)) (m + (n-1))  invertible_mat P  sub_PreHNF = P * A'_DR"
      by (unfold sub_PreHNF_def, rule FindPreHNF_invertible_mat_mx2
          [OF A'DR_A'DR_m_D A'_DR_m _ _ D0 _])
          (insert False m_le_n n0 m0 "1"(4), auto)
    moreover have "echelon_form_JNF sub_PreHNF" unfolding sub_PreHNF_def 
      by (rule FindPreHNF_echelon_form_mx1[OF A'DR_A'DR_m_D A'_DR_m _ D0 _],
          insert False n0 m_le_n, auto) 
    ultimately show ?thesis by simp
  qed  
  from this obtain P where P: "P  carrier_mat (m + (n - 1)) (m + (n - 1))"
    and inv_P: "invertible_mat P" and sub_PreHNF_P_A'_DR: "sub_PreHNF = P * A'_DR" by blast
  define P' where "P' = (four_block_mat (1m 1) (0m 1 (m+(n-1))) (0m (m+(n-1)) 1) P)"
  have P': "P'  carrier_mat (m+n) (m+n)" 
  proof -
    have "P'  carrier_mat (1 + (m+(n-1))) (1 + (m+(n-1))) "
      unfolding P'_def by (rule four_block_carrier_mat[OF _ P], simp) 
    thus ?thesis using n by auto
  qed
  have inv_P': "invertible_mat P'" 
    unfolding P'_def by (rule invertible_mat_four_block_mat_lower_right[OF P inv_P])
  have dr_A2: "dim_row A  2" using A m0 n by auto
  have dc_A2: "dim_col A  2" using n A by blast
  have *: "(dim_col A = 0) = False" using dc_A2 by auto
  have FindPreHNF_as_fbm: "FindPreHNF abs_flag D A = four_block_mat A'_UL A'_UR A'_DL sub_PreHNF" 
    unfolding FindPreHNF.simps[of abs_flag D A] using A'_split mn n A dr_A2 dc_A2 False
    unfolding Let_def sub_PreHNF_def M_def A'_def non_zero_positions_def *    
    by (smt (z3) linorder_not_less split_conv)
  also have "... = P' * (reduce_below 0 non_zero_positions D M)"
  proof -
    have "P' * (reduce_below 0 non_zero_positions D M) 
      = four_block_mat (1m 1) (0m 1 (m + (n - 1))) (0m (m + (n - 1)) 1) P 
      * four_block_mat A'_UL A'_UR A'_DL A'_DR"
      unfolding P'_def fbm_R[unfolded M_def[symmetric], symmetric] ..
    also have "... = four_block_mat 
            ((1m 1) * A'_UL + (0m 1 (m + (n - 1)) * A'_DL)) 
            ((1m 1) * A'_UR + (0m 1 (m + (n - 1))) * A'_DR) 
            ((0m (m + (n - 1)) 1) * A'_UL + P * A'_DL) 
            ((0m (m + (n - 1)) 1) * A'_UR + P * A'_DR)" 
      by (rule mult_four_block_mat[OF _ _ _ P A'_UL A'_UR A'_DL A'_DR], auto)
    also have "... = four_block_mat A'_UL A'_UR (P * A'_DL) (P * A'_DR)"
      by (rule cong_four_block_mat, insert A'_UL A'_UR A'_DL A'_DR P, auto)
    also have "... = four_block_mat A'_UL A'_UR (0m (m + (n - 1)) 1) sub_PreHNF"
      unfolding A'_DL0 sub_PreHNF_P_A'_DR using P by simp
    also have "... = four_block_mat A'_UL A'_UR A'_DL sub_PreHNF"
      unfolding A'_DL0 by simp
    finally show ?thesis ..
  qed
  finally have Find_P'_reduceM: "FindPreHNF abs_flag D A =  P' * (reduce_below 0 non_zero_positions D M)" .
  have "Q. invertible_mat Q  Q  carrier_mat (m + n) (m + n) 
     reduce_below 0 (xs @ [m]) D M = Q * M"
  proof (cases "xs = []")
    case True note xs_empty = True
    have rw: "reduce_below 0 (xs @ [m]) D M = reduce 0 m D M" using True by auto
    obtain p q u v d where pquvd: "(p, q, u, v, d) = euclid_ext2 (M $$ (0, 0)) (M $$ (m, 0))"
      by (simp add: euclid_ext2_def)
    have "P. invertible_mat P  P  carrier_mat (m + n) (m + n)  reduce 0 m D M = P * M"  
    proof (rule reduce_invertible_mat_case_m[OF _ _ m0 _ _ _ _ m_le_n n0 pquvd])
          show "M $$ (0, 0)  0" 
            using M_def mk_A'_not0 by blast
          define M' where  "M' = mat_of_rows n (map (Matrix.row M) [0..<m])"
          define M'' where "M'' = mat_of_rows n (map (Matrix.row M) [m..<m+n])"
          define A2 where "A2 = Matrix.mat (dim_row M) (dim_col M)
          (λ(i, k). if i = 0 then p * M $$ (0, k) + q * M $$ (m, k) 
                    else if i = m then u * M $$ (0, k) + v * M $$ (m, k)
                    else M $$ (i, k))"
          show M_M'_M'': "M = M' @r M''" unfolding M'_def M''_def            
            by (metis M append_rows_split carrier_matD le_add1)
          show M': "M'  carrier_mat m n" unfolding M'_def by fastforce
          show M'': "M''  carrier_mat n n" unfolding M''_def by fastforce
          show "0  m" using m0 by simp
          show "A2 = Matrix.mat (dim_row M) (dim_col M)
          (λ(i, k). if i = 0 then p * M $$ (0, k) + q * M $$ (m, k) 
                    else if i = m then u * M $$ (0, k) + v * M $$ (m, k)
                    else M $$ (i, k))"
            (is "_ = ?rhs") using A A2_def by auto
          define xs' where "xs' = [1..<n]"
          define ys' where  "ys' = [1..<n]"
          show "xs' = [1..<n]" unfolding xs'_def by auto
          show "ys' = [1..<n]" unfolding ys'_def by auto
          have M''D: "(M'' $$ (j, j) = D)  (j'{0..<n}-{j}. M'' $$ (j, j') = 0)"
            if jn: "j<n" and j0: "j>0" for j
          proof -
            have Ajm0: "A $$ (j+m,0) = 0"
            proof -
              have "A $$ (j+m,0) = (D m 1m n) $$ (j+m-m,0)"
                by (smt "1"(2) "1"(3) M M' M'' M_M'_M'' add.commute append_rows_def carrier_matD
                    diff_add_inverse2 index_mat_four_block index_one_mat(2) index_smult_mat(2)
                    le_add2 less_diff_conv2 n0 not_add_less2 that(1))
              also have "... = 0" using jn j0 by auto
              finally show ?thesis .
            qed
            have "M'' $$ (j, i) = (D m 1m n) $$ (j,i)" if i_n: "i<n" for i
            proof (cases "A$$(0,0) = 0")
              case True 
              have "M'' $$ (j, i) = make_first_column_positive (swaprows 0 m A) $$ (j+m,i)"                
                by (smt A'_def Groups.add_ac(2) M' M'' M_M'_M'' M_def True append.simps(1) 
                    append_rows_nth3 diff_add_inverse2 jn le_add2 local.non_zero_positions_xs_m
                    nat_add_left_cancel_less nth_Cons_0 that xs_empty)
              also have "... = A $$ (j+m,i)" using A jn j0 i_n Ajm0 by auto
              also have "... = (D m 1m n) $$ (j,i)"
                by (smt A Groups.add_ac(2) add_mono_thms_linordered_field(1) append_rows_def A_def A'' i_n
                    carrier_matD index_mat_four_block(1,2) add_diff_cancel_right' not_add_less2 jn trans_less_add1)
              finally show ?thesis .            
            next
              case False
              have "A' = A" unfolding A'_def non_zero_positions_xs_m using False True by auto
              hence "M'' $$ (j, i) = make_first_column_positive A $$ (j+m,i)"                
                by (smt m_le_n M' M'' M_M'_M'' M_def append_rows_nth2 jn nat_SN.compat that)                
              also have "... = A $$ (j+m,i)" using A jn j0 i_n Ajm0 by auto
              also have "... = (D m 1m n) $$ (j,i)"
                by (smt A Groups.add_ac(2) add_mono_thms_linordered_field(1) append_rows_def A_def A'' i_n
                    carrier_matD index_mat_four_block(1,2) add_diff_cancel_right' not_add_less2 jn trans_less_add1)
              finally show ?thesis .
            qed                           
            thus ?thesis using jn j0 by auto
          qed
          have Am0D: "A$$(m,0) = D"
          proof -
            have "A$$(m,0) = (D m 1m n) $$ (m-m,0)"
              by (smt "1"(2) "1"(3) M M' M'' M_M'_M'' append_rows_def carrier_matD
                  diff_less_mono2 diff_self_eq_0 index_mat_four_block index_one_mat(2) 
                  index_smult_mat(2) less_add_same_cancel1 n0 semiring_norm(137))
            also have "... = D" using m0 n0 by auto
            finally show ?thesis .
          qed
          hence S00D: "(swaprows 0 m A) $$ (0,0) = D" using n0 m0 A by auto
          have Sm00: "(swaprows 0 m A) $$ (m,0) = A$$(0,0)" using n0 m0 A by auto
          have M00D: "M $$ (0, 0) = D" if A00: "A$$(0,0) = 0"
          proof -
            have "M $$ (0,0) = (make_first_column_positive (swaprows 0 m A)) $$ (0,0)"
              unfolding M_def A'_def using A00
              by (simp add: True non_zero_positions_xs_m)
            also have "... = (if (swaprows 0 m A) $$ (0,0) < 0 then - (swaprows 0 m A) $$(0,0)
                              else (swaprows 0 m A) $$(0,0))"
              unfolding make_first_column_positive.simps using m0 n0 A by auto
            also have "... = (swaprows 0 m A) $$(0,0)" using S00D D0 by auto
            also have "... = D" using S00D by auto
            finally show ?thesis .
          qed
          have Mm00: "M $$ (m, 0) = 0" if A00: "A$$(0,0) = 0"
          proof -
            have "M $$ (m,0) = (make_first_column_positive (swaprows 0 m A)) $$ (m,0)"
              unfolding M_def A'_def using A00
              by (simp add: True non_zero_positions_xs_m)
            also have "... = (if (swaprows 0 m A) $$ (m,0) < 0 then - (swaprows 0 m A) $$(m,0)
                              else (swaprows 0 m A) $$(m,0))"
              unfolding make_first_column_positive.simps using m0 n0 A by auto
            also have "... = (swaprows 0 m A) $$(m,0)" using Sm00 A00 D0 by auto
            also have "... = 0" using Sm00 A00 by auto
            finally show ?thesis .
          qed
          have M000: "M $$ (0, 0) = abs (A$$(0,0))" if A00: "A$$(0,0)  0"
          proof -
            have "M $$ (0,0) = (make_first_column_positive A) $$ (0,0)"
              unfolding M_def A'_def using A00
              by (simp add: True non_zero_positions_xs_m)
            also have "... = (if A $$ (0,0) < 0 then - A $$(0,0)
                              else A $$(0,0))"
              unfolding make_first_column_positive.simps using m0 n0 A by auto
            also have "... = abs (A$$(0,0))" using Sm00 A00 by auto
            finally show ?thesis .
          qed
          have Mm0D: "M $$ (m, 0) = D" if A00: "A $$ (0,0)  0"
          proof -
            have "M $$ (m,0) = (make_first_column_positive A) $$ (m,0)"
              unfolding M_def A'_def using A00
              by (simp add: True non_zero_positions_xs_m)
            also have "... = (if A $$ (m,0) < 0 then - A $$(m,0)
                              else A $$(m,0))"
              unfolding make_first_column_positive.simps using m0 n0 A by auto
            also have "... = A $$(m,0)" using S00D D0 Am0D by auto
            also have "... = D" using Am0D D0 by auto
            finally show ?thesis .
          qed
          have "0  set xs'"
          proof -
            have "A2 $$ (0,0) = p * M $$ (0, 0) + q * M $$ (m, 0)" 
              using A A2_def n0 M by auto
            also have "... = gcd (M $$ (0, 0)) (M $$ (m, 0))"
              by (metis euclid_ext2_works(1,2) pquvd)
            also have "abs ...  D" using M00D Mm00 M000 Mm0D using gcd_0_int D0 by fastforce
            finally have "abs (A2 $$ (0,0))  D" .
            thus ?thesis unfolding xs'_def using D0 by auto
          qed
          thus "jset xs'. j<n  (M'' $$ (j, j) = D)  (j'{0..<n}-{j}. M'' $$ (j, j') = 0)"  
            using M''D xs'_def by auto
          have "0  set ys'"
          proof -
            have "A2 $$ (m,0) = u * M $$ (0, 0) + v * M $$ (m, 0)"
              using A A2_def n0 m0 M by auto
            also have "... = - M $$ (m, 0) div gcd (M $$ (0, 0)) (M $$ (m, 0)) * M $$ (0, 0) 
                + M $$ (0, 0) div gcd (M $$ (0, 0)) (M $$ (m, 0)) * M $$ (m, 0) "
              by (simp add: euclid_ext2_works[OF pquvd[symmetric]])
            also have "... = 0" using M00D Mm00 M000 Mm0D
              by (smt dvd_div_mult_self euclid_ext2_works(3) euclid_ext2_works(5)
                  more_arith_simps(11) mult.commute mult_minus_left pquvd semiring_gcd_class.gcd_dvd1)
            finally have "A2 $$ (m,0) = 0" .
            thus ?thesis unfolding ys'_def using D0 by auto
          qed
          thus "jset ys'. j<n  (M'' $$ (j, j) = D)  (j'{0..<n}-{j}. M'' $$ (j, j') = 0)"
            using M''D ys'_def by auto   
          show "M $$ (m, 0)  {0,D}" using Mm00 Mm0D by blast
          show " M $$ (m, 0) = 0  M $$ (0, 0) = D"  using Mm00 Mm0D D_not0 M00D by blast          
        qed (insert D0)
        then show ?thesis using rw by auto
  next
    case False
    show ?thesis
      by (unfold M_def, rule reduce_below_invertible_mat_case_m[OF M' m0 n0 M_M'D[OF False] 
          mk_A'_not0 m_le_n d_xs all_less_m D0])
  qed
   
  from this obtain Q where inv_Q: "invertible_mat Q" and Q: "Q  carrier_mat (m + n) (m + n)"
    and reduce_QM: "reduce_below 0 (xs @ [m]) D M = Q * M" by blast
  have "R. invertible_mat R 
     R  carrier_mat (dim_row A') (dim_row A')  M = R * A'"
    by (unfold M_def, rule make_first_column_positive_invertible)
  from this obtain R where inv_R: "invertible_mat R"
    and R: "R  carrier_mat (dim_row A') (dim_row A')" and M_RA': "M = R * A'" by blast
  have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P  A' = P * A" 
    by (rule A'_swaprows_invertible_mat[OF A A'_def non_zero_positions_def],
        insert non_zero_positions_xs_m n m0, auto)
  from this obtain S where inv_S: "invertible_mat S"
   and S: "S  carrier_mat (dim_row A) (dim_row A)" and A'_SA: "A' = S * A" 
    using A by auto
  have "(P'*Q*R*S)  carrier_mat (m+n) (m+n)" using P' Q R S A' A by auto
  moreover have "FindPreHNF abs_flag D A = (P'*Q*R*S) * A" using Find_P'_reduceM reduce_QM 
    unfolding  M_RA' A'_SA M_def
    by (smt A' A'_SA P' Q R S assoc_mult_mat carrier_matD carrier_mat_triv index_mult_mat(2,3) 
        non_zero_positions_xs_m)
  moreover have "invertible_mat (P'*Q*R*S)" using inv_P' inv_Q inv_R inv_S using P' Q R S A' A 
    by (metis carrier_matD carrier_mat_triv index_mult_mat(2,3) invertible_mult_JNF)
  ultimately have exists_inv: "P. P  carrier_mat (m + n) (m + n)  invertible_mat P 
     FindPreHNF abs_flag D A = P * A" by blast
  moreover have "echelon_form_JNF (FindPreHNF abs_flag D A)" 
  proof (rule echelon_form_four_block_mat[OF A'_UL A'_UR sub_PreHNF'   ])
    show "FindPreHNF abs_flag D A = four_block_mat A'_UL A'_UR (0m (m + n - 1) 1) sub_PreHNF" 
      using A'_DL0 FindPreHNF_as_fbm sub_PreHNF sub_PreHNF' by auto
    have "A'_UL $$ (0, 0) = ?R $$ (0,0)"
      by (metis (mono_tags, lifting) A A'_DR A'_UL Find_P'_reduceM M_def 
          ‹FindPreHNF abs_flag D A = P' * Q * R * S * A add_Suc_right add_sign_intros(2) carrier_matD fbm_R
          index_mat_four_block(1,3) index_mult_mat(3) m0 n0 plus_1_eq_Suc
          zero_less_one_class.zero_less_one)
    also have "...  0"
    proof (cases "xs=[]")
      case True
      have "?R $$ (0,0) = reduce 0 m D M $$ (0,0)"
        unfolding non_zero_positions_xs_m True M_def by simp
      also have "...  0"
        by (metis D_not0 M M_def add_pos_pos less_add_same_cancel1 m0 mk_A'_not0 n0 reduce_not0)
      finally show ?thesis .
    next
      case False
      show ?thesis
        by (unfold non_zero_positions_xs_m,
          rule reduce_below_not0_case_m[OF M' m0 n0 M_M'D[OF False] mk_A'_not0 m_le_n all_less_m D_not0])     
    qed       
    finally show "A'_UL $$ (0, 0)  0" .
  qed (insert mn n hyp, auto)
  ultimately show ?thesis by blast
qed
qed

lemma
  assumes A_def: "A = A'' @r D m 1m n"
  and A'': "A''  carrier_mat m n" and "n2" and m_le_n: "mn" and "D>0"
shows FindPreHNF_invertible_mat_n_ge2: "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  FindPreHNF abs_flag D A = P * A"
and FindPreHNF_echelon_form_n_ge2: "echelon_form_JNF (FindPreHNF abs_flag D A)"
  using FindPreHNF_works_n_ge2[OF assms] by blast+

lemma FindPreHNF_invertible_mat:
  assumes A_def: "A = A'' @r D m 1m n"
    and A'': "A''  carrier_mat m n" and n0: "0<n" and mn: "mn" and D: "D>0"
  shows "P. P  carrier_mat (m+n) (m+n)  invertible_mat P  FindPreHNF abs_flag D A = P * A"
proof -
  have A: "A  carrier_mat (m+n) n" using A_def A'' by auto
  show ?thesis
  proof (cases "m+n<2")
    case True
    show ?thesis by (rule FindPreHNF_invertible_mat_2xn[OF A True])
  next
    case False note m_ge2 = False
    show ?thesis
    proof (cases "n<2")
      case True
      show ?thesis by (rule FindPreHNF_invertible_mat_mx2[OF A_def A'' True n0 D mn])
    next
      case False
      show ?thesis 
        by (rule FindPreHNF_invertible_mat_n_ge2[OF A_def A'' _ mn D], insert False, auto)
    qed  
  qed
qed


lemma FindPreHNF_echelon_form:
  assumes A_def: "A = A'' @r D m 1m n"
    and A'': "A''  carrier_mat m n" and mn: "mn" and D: "D>0"
  shows "echelon_form_JNF (FindPreHNF abs_flag D A)"
proof -
  have A: "A  carrier_mat (m+n) n" using A_def A'' by auto
  have FindPreHNF: "(FindPreHNF abs_flag D A)  carrier_mat (m+n) n" by (rule FindPreHNF[OF A])
  show ?thesis
  proof (cases "m+n<2")
    case True
    show ?thesis by (rule echelon_form_JNF_1xn[OF FindPreHNF True])
  next
    case False note m_ge2 = False
    show ?thesis
    proof (cases "n<2")
      case True
      show ?thesis by (rule FindPreHNF_echelon_form_mx1[OF A_def A'' True D mn])
    next
      case False
      show ?thesis 
        by (rule FindPreHNF_echelon_form_n_ge2[OF A_def A'' _ mn D], insert False, auto)
    qed  
  qed
qed
end

text ‹We connect the algorithm developed in the Hermite AFP entry with ours. This would permit
to reuse many existing results and prove easily the soundness.›

(*In HOL Analysis*)
thm Hermite.Hermite_reduce_above.simps
thm Hermite.Hermite_of_row_i_def
thm Hermite.Hermite_of_upt_row_i_def
thm Hermite.Hermite_of_def

(*In JNF*)
thm Hermite_reduce_above.simps
thm Hermite_of_row_i_def
thm Hermite_of_list_of_rows.simps
thm mod_operation.Hermite_mod_det_def

(*Connecting Hermite.Hermite_reduce_above and Hermite_reduce_above*)
thm Hermite.Hermite_reduce_above.simps Hermite_reduce_above.simps

context includes lifting_syntax
begin

definition "res_int = (λb n::int. n mod b)"

lemma res_function_res_int: 
  "res_function res_int"
  using res_function_euclidean2 unfolding res_int_def by auto

lemma HMA_Hermite_reduce_above[transfer_rule]: 
  assumes "n<CARD('m)"
  shows "((Mod_Type_Connect.HMA_M :: _  int ^ 'n :: mod_type ^ 'm :: mod_type  _) 
    ===> (Mod_Type_Connect.HMA_I) ===> (Mod_Type_Connect.HMA_I) ===> (Mod_Type_Connect.HMA_M)) 
  (λA i j. Hermite_reduce_above A n i j)
  (λA i j. Hermite.Hermite_reduce_above A n i j res_int)"
proof (intro rel_funI, goal_cases)
  case (1 A A' i i' j j')
  then show ?case using assms
  proof (induct n arbitrary: A A')
    case 0
    then show ?case by auto
  next
    case (Suc n)
    note AA'[transfer_rule] = "Suc.prems"(1)
    note ii'[transfer_rule] = "Suc.prems"(2)
    note jj'[transfer_rule] = "Suc.prems"(3)
    note Suc_n_less_m = "Suc.prems"(4)

    let ?H_JNF = "HNF_Mod_Det_Algorithm.Hermite_reduce_above"
    let ?H_HMA = "Hermite.Hermite_reduce_above"
    let ?from_nat_rows = "mod_type_class.from_nat :: _  'm"
    have nn[transfer_rule]: "Mod_Type_Connect.HMA_I n (?from_nat_rows n)" 
      unfolding Mod_Type_Connect.HMA_I_def
      by (simp add: Suc_lessD Suc_n_less_m mod_type_class.from_nat_to_nat)

    have Anj: "A' $h (?from_nat_rows n) $h j' = A $$ (n,j)" 
      by (unfold index_hma_def[symmetric], transfer, simp)
    have Aij: "A' $h i' $h j' = A $$ (i,j)" by (unfold index_hma_def[symmetric], transfer, simp)
    let ?s = "(- (A $$ (n, j) div A $$ (i, j)))"
    let ?s' = "((res_int (A' $h i' $h j') (A' $h ?from_nat_rows n $h j') 
      - A' $h ?from_nat_rows n $h j') div A' $h i' $h j')"
    have ss'[transfer_rule]: "?s = ?s'" unfolding res_int_def Anj Aij
      by (metis (no_types, hide_lams) Groups.add_ac(2) add_diff_cancel_left' div_by_0 
          minus_div_mult_eq_mod more_arith_simps(7) nat_arith.rule0 nonzero_mult_div_cancel_right
          uminus_add_conv_diff)
    have H_JNF_eq: "?H_JNF A (Suc n) i j = ?H_JNF (addrow (- (A $$ (n, j) div A $$ (i, j))) n i A) n i j"
      by auto
    have H_HMA_eq: "?H_HMA A' (Suc n) i' j' res_int = ?H_HMA (row_add A' (?from_nat_rows n) i' ?s') n i' j' res_int"
      by (auto simp add: Let_def)
    have "Mod_Type_Connect.HMA_M (?H_JNF (addrow ?s n i A) n i j) 
      (?H_HMA (row_add A' (?from_nat_rows n) i' ?s') n i' j' res_int)" 
      by (rule "Suc.hyps"[OF _ ii' jj'], transfer_prover, insert Suc_n_less_m, simp)
    thus ?case using H_JNF_eq H_HMA_eq by auto
  qed
qed


corollary HMA_Hermite_reduce_above': 
  assumes "n<CARD('m)"
  and "Mod_Type_Connect.HMA_M A (A':: int ^ 'n :: mod_type ^ 'm :: mod_type)"
  and "Mod_Type_Connect.HMA_I i i'" and "Mod_Type_Connect.HMA_I j j'"
  shows"Mod_Type_Connect.HMA_M (Hermite_reduce_above A n i j) (Hermite.Hermite_reduce_above A' n i' j' res_int)"
  using HMA_Hermite_reduce_above assms unfolding rel_fun_def by metis


lemma HMA_Hermite_of_row_i[transfer_rule]: 
  assumes upt_A: "upper_triangular' A"
  and AA': "Mod_Type_Connect.HMA_M A (A':: int ^ 'n :: mod_type ^ 'm :: mod_type)"
  and ii': "Mod_Type_Connect.HMA_I i i'"
  shows "Mod_Type_Connect.HMA_M (Hermite_of_row_i A i)
  (Hermite.Hermite_of_row_i ass_function_euclidean res_int A' i')"
proof -
  note AA'[transfer_rule]
  note ii'[transfer_rule]
  have i: "i<dim_row A"
    by (metis (full_types) AA' ii' Mod_Type_Connect.HMA_I_def 
        Mod_Type_Connect.dim_row_transfer_rule mod_type_class.to_nat_less_card)  
  show ?thesis
  proof (cases "is_zero_row i' A'")
    case True
    hence "is_zero_row_JNF i A" by (transfer, simp)
    hence "find_fst_non0_in_row i A = None" using find_fst_non0_in_row_None[OF _ upt_A i] by auto
    thus ?thesis using True AA' unfolding Hermite.Hermite_of_row_i_def Hermite_of_row_i_def by auto
  next
    case False
    have nz_iA: "¬ is_zero_row_JNF i A" using False by transfer
    hence "find_fst_non0_in_row i A  None" using find_fst_non0_in_row_None[OF _ upt_A i] by auto
    from this obtain j where j: "find_fst_non0_in_row i A = Some j" by blast
    have j_eq: "j = (LEAST n. A $$ (i,n)  0)"
      by (rule find_fst_non0_in_row_LEAST[OF _ upt_A j i], auto)
    have H_JNF_rw: "(Hermite_of_row_i A i) = 
    (if A $$ (i, j) < 0 then Hermite_reduce_above (multrow i (- 1) A) i i j
     else Hermite_reduce_above A i i j)" unfolding Hermite_of_row_i_def using j by auto
    let ?H_HMA = "Hermite.Hermite_of_row_i"
    let ?j' = "(LEAST n. A' $h i' $h n  0)"
    have ii'2: "(mod_type_class.to_nat i') = i" using ii'
      by (simp add: Mod_Type_Connect.HMA_I_def)                                            
    have jj'[transfer_rule]: "Mod_Type_Connect.HMA_I j ?j'"
      unfolding j_eq index_hma_def[symmetric] by (rule HMA_LEAST[OF AA' ii' nz_iA])
    have Aij: "A $$ (i, j) = A' $h i' $h (LEAST n. A' $h i' $h n  0)"
      by (subst index_hma_def[symmetric], transfer', simp)
    have H_HMA_rw: "?H_HMA ass_function_euclidean res_int A' i' = 
    Hermite.Hermite_reduce_above (mult_row A' i' (¦A' $h i' $h ?j'¦ 
      div A' $h i' $h ?j'))
     (mod_type_class.to_nat i') i' ?j' res_int" 
      unfolding Hermite.Hermite_of_row_i_def Let_def ass_function_euclidean_def
      by (auto simp add: False)
    have im: "i < CARD('m)" using ii' unfolding Mod_Type_Connect.HMA_I_def
      using mod_type_class.to_nat_less_card by blast
    show ?thesis
    proof (cases "A $$ (i, j) < 0")
      case True
      have A'i'j'_le_0: "A' $h i' $h ?j' < 0" using Aij True by auto
      hence 1: "(¦A' $h i' $h ?j'¦ div A' $h i' $h ?j') 
          = -1" using div_pos_neg_trivial by auto
      have [transfer_rule]: "Mod_Type_Connect.HMA_M (multrow i (- 1) A) 
      (mult_row A' i' (¦A' $h i' $h ?j'¦ 
      div A' $h i' $h ?j'))" unfolding 1 by transfer_prover      
      have H_HMA_rw2: "Hermite_of_row_i A i = Hermite_reduce_above (multrow i (- 1) A) i i j"
        using True H_JNF_rw by auto
      have *: "Mod_Type_Connect.HMA_M (Hermite_reduce_above (multrow i (- 1) A) i i j) 
        (Hermite.Hermite_reduce_above (mult_row A' i' (¦A' $h i' $h ?j'¦ 
        div A' $h i' $h ?j'))
        (mod_type_class.to_nat i') i' ?j' res_int) "
        unfolding 1 ii'2
        by (rule HMA_Hermite_reduce_above'[OF im _ ii' jj'], transfer_prover)
       show ?thesis unfolding H_JNF_rw H_HMA_rw unfolding H_HMA_rw2 using True * by auto
    next
      case False
      have Aij_not0: "A $$ (i, j)  0" using j_eq nz_iA
        by (metis (mono_tags) LeastI is_zero_row_JNF_def)
      have A'i'j'_le_0: "A' $h i' $h ?j' > 0" using False Aij_not0 Aij by auto
      hence 1: "(¦A' $h i' $h ?j'¦ div A' $h i' $h ?j') = 1" by auto
      have H_HMA_rw2: "Hermite_of_row_i A i = Hermite_reduce_above A i i j"
        using False H_JNF_rw by auto
      have *: "?H_HMA ass_function_euclidean res_int A' i' = 
      (Hermite.Hermite_reduce_above A' (mod_type_class.to_nat i') i' ?j' res_int)"
        using H_HMA_rw unfolding 1 unfolding mult_row_1_id by simp
      have "Mod_Type_Connect.HMA_M (Hermite_reduce_above A i i j) 
        (Hermite.Hermite_reduce_above A' (mod_type_class.to_nat i') i' ?j' res_int)"
        unfolding 1 ii'2
        by (rule HMA_Hermite_reduce_above'[OF im AA' ii' jj'])
      then show ?thesis using H_HMA_rw * H_HMA_rw2 by presburger
    qed        
  qed
qed


lemma Hermite_of_list_of_rows_append:
"Hermite_of_list_of_rows A (xs @ [x]) = Hermite_of_row_i (Hermite_of_list_of_rows A xs) x"
  by (induct xs arbitrary: A, auto)


lemma Hermite_reduce_above[simp]: "Hermite_reduce_above A n i j  carrier_mat (dim_row A) (dim_col A)"  
proof (induct n arbitrary: A)
  case 0
  then show ?case by auto
next
  case (Suc n)    
  let ?A = "(addrow (- (A $$ (n, j) div A $$ (i, j))) n i A)"  
  have "Hermite_reduce_above A (Suc n) i j = Hermite_reduce_above ?A n i j"
    by (auto simp add: Let_def)
  also have "...  carrier_mat (dim_row ?A) (dim_col ?A)" by(rule Suc.hyps)
  finally show ?case by auto  
qed                           


lemma Hermite_of_row_i: "Hermite_of_row_i A i  carrier_mat (dim_row A) (dim_col A)" 
proof -
  have "Hermite_reduce_above (multrow i (- 1) A) i i a 
     carrier_mat (dim_row (multrow i (- 1) A)) (dim_col (multrow i (- 1) A))" 
    for a by (rule Hermite_reduce_above)
  thus ?thesis
    unfolding Hermite_of_row_i_def using Hermite_reduce_above 
    by (cases "find_fst_non0_in_row i A", auto)
qed

end


text ‹We now move more lemmas from HOL Analysis (with mod-type restrictions) to the JNF matrix
representation.›

(*thm echelon_form_Hermite_of_row will be transferred from HOL Analysis to JNF*)

context
begin

private lemma echelon_form_Hermite_of_row_mod_type:
  fixes A::"int mat"
  assumes "A  carrier_mat CARD('m::mod_type) CARD('n::mod_type)"
  assumes eA: "echelon_form_JNF A"
  and i: "i<CARD('m)"
  shows "echelon_form_JNF (Hermite_of_row_i A i)"
proof -
  have uA: "upper_triangular' A" by (rule echelon_form_JNF_imp_upper_triangular[OF eA])
  define A' where "A' = (Mod_Type_Connect.to_hmam A :: int ^'n :: mod_type ^'m :: mod_type)"
  define i' where "i' = (Mod_Type.from_nat i :: 'm)"
  have AA'[transfer_rule]: "Mod_Type_Connect.HMA_M A A'"
    unfolding Mod_Type_Connect.HMA_M_def using assms A'_def by auto
  have ii'[transfer_rule]: "Mod_Type_Connect.HMA_I i i'"
    unfolding Mod_Type_Connect.HMA_I_def i'_def using assms
    using from_nat_not_eq order.strict_trans by blast 
  have eA'[transfer_rule]: "echelon_form A'" using eA by transfer
  have [transfer_rule]: "Mod_Type_Connect.HMA_M 
    (HNF_Mod_Det_Algorithm.Hermite_of_row_i A i) 
    (Hermite.Hermite_of_row_i ass_function_euclidean res_int A' i')"
    by (rule HMA_Hermite_of_row_i[OF uA AA' ii'])
  have "echelon_form (Hermite.Hermite_of_row_i ass_function_euclidean res_int A' i')"
    by (rule echelon_form_Hermite_of_row[OF ass_function_euclidean res_function_res_int eA'])    
  thus ?thesis by (transfer, simp)
qed 


private lemma echelon_form_Hermite_of_row_nontriv_mod_ring:
  fixes A::"int mat"
  assumes "A  carrier_mat CARD('m::nontriv mod_ring) CARD('n::nontriv mod_ring)"
  assumes eA: "echelon_form_JNF A"
  and "i<CARD('m)"
  shows "echelon_form_JNF (Hermite_of_row_i A i)"
using assms echelon_form_Hermite_of_row_mod_type by (smt CARD_mod_ring) 

(*We internalize both sort constraints in one step*)
lemmas echelon_form_Hermite_of_row_nontriv_mod_ring_internalized = 
  echelon_form_Hermite_of_row_nontriv_mod_ring[unfolded CARD_mod_ring, 
      internalize_sort "'m::nontriv", internalize_sort "'b::nontriv"]

context
  fixes m::nat and n::nat
  assumes local_typedef1: "(Rep :: ('b  int)) Abs. type_definition Rep Abs {0..<m :: int}"
  assumes local_typedef2: "(Rep :: ('c  int)) Abs. type_definition Rep Abs {0..<n :: int}"
  and m: "m>1"
  and n: "n>1"
begin

lemma echelon_form_Hermite_of_row_nontriv_mod_ring_aux:
 fixes A::"int mat"
  assumes "A  carrier_mat m n"
  assumes eA: "echelon_form_JNF A"
  and "i<m"
shows "echelon_form_JNF (Hermite_of_row_i A i)"  
  using echelon_form_Hermite_of_row_nontriv_mod_ring_internalized
    [OF type_to_set2(1)[OF local_typedef1 local_typedef2] 
        type_to_set1(1)[OF local_typedef1 local_typedef2]]
  using assms 
  using type_to_set1(2) local_typedef1 local_typedef2 n m by metis 

end

(*Canceling the first local type definitions*)
context
begin

(*Canceling the first*)

private lemma echelon_form_Hermite_of_row_i_cancelled_first:
"Rep Abs. type_definition Rep Abs {0..<int n}  1 < m  1 < n 
   A  carrier_mat m n  echelon_form_JNF A  i < m 
   echelon_form_JNF (HNF_Mod_Det_Algorithm.Hermite_of_row_i A i)"
  using echelon_form_Hermite_of_row_nontriv_mod_ring_aux[cancel_type_definition, of m n A i]
  by auto  

(*Canceling the second*)
private lemma echelon_form_Hermite_of_row_i_cancelled_both:
"1 < m  1 < n  A  carrier_mat m n  echelon_form_JNF A  i < m 
   echelon_form_JNF (HNF_Mod_Det_Algorithm.Hermite_of_row_i A i)"
  using echelon_form_Hermite_of_row_i_cancelled_first[cancel_type_definition, of n m A i] by simp

(*The final results in JNF*)

lemma echelon_form_JNF_Hermite_of_row_i':
 fixes A::"int mat"
  assumes "A  carrier_mat m n"
  assumes eA: "echelon_form_JNF A"
  and "i<m"
  and "1 < m" and "1 < n" (*Required from the mod_type restrictions*)
shows "echelon_form_JNF (Hermite_of_row_i A i)"  
  using echelon_form_Hermite_of_row_i_cancelled_both assms by auto


corollary echelon_form_JNF_Hermite_of_row_i:
  fixes A::"int mat"
  assumes eA: "echelon_form_JNF A"
    and i: "i<dim_row A"
  shows "echelon_form_JNF (Hermite_of_row_i A i)"  
proof (cases "dim_row A < 2")
  case True
  show ?thesis 
    by (rule echelon_form_JNF_1xn[OF Hermite_of_row_i True])
next
  case False note m_ge2 = False
  show ?thesis
  proof (cases "1<dim_col A")
    case True
    show ?thesis by (rule echelon_form_JNF_Hermite_of_row_i'[OF _ eA i _ True], insert m_ge2, auto)
  next
    case False
    hence dc_01: "dim_col A  {0,1}" by auto
    show ?thesis
    proof (cases "dim_col A = 0")
      case True
      have H: "Hermite_of_row_i A i  carrier_mat (dim_row A) (dim_col A)"
        using Hermite_of_row_i by blast
      show ?thesis by (rule echelon_form_mx0, insert True H, auto)
    next
      case False
      hence dc_1: "dim_col A = 1" using dc_01 by simp
      then show ?thesis     
      proof (cases "i=0")
        case True      
        have eA': "echelon_form_JNF (multrow 0 (- 1) A)"
          by (rule echelon_form_JNF_multrow[OF _ _ eA], insert m_ge2, auto)
        show ?thesis using True unfolding Hermite_of_row_i_def
          by (cases "find_fst_non0_in_row 0 A", insert eA eA', auto)
      next
        case False  
        have all_zero: "(j{i..<dim_col A}. A $$ (i, j) = 0)" unfolding dc_1 using False by auto
        hence "find_fst_non0_in_row i A = None" using find_fst_non0_in_row_None'[OF _ i] by blast
        hence "Hermite_of_row_i A i = A" unfolding Hermite_of_row_i_def by auto
        then show ?thesis using eA by auto
      qed  
    qed  
  qed
qed



lemma Hermite_of_list_of_rows:
 "(Hermite_of_list_of_rows A xs)  carrier_mat (dim_row A) (dim_col A)"
proof (induct xs arbitrary: A rule: rev_induct)
  case Nil
  then show ?case by auto
next
  case (snoc x xs)
  let ?A = "(Hermite_of_list_of_rows A xs)"
  have hyp: "(Hermite_of_list_of_rows A xs)  carrier_mat (dim_row A) (dim_col A)" by (rule snoc.hyps)
  have "Hermite_of_list_of_rows A (xs @ [x]) = Hermite_of_row_i ?A x"
    using Hermite_of_list_of_rows_append by auto
  also have "...  carrier_mat (dim_row ?A) (dim_col ?A)" using Hermite_of_row_i by auto
  finally show ?case using hyp by auto  
qed

lemma echelon_form_JNF_Hermite_of_list_of_rows:
  assumes "Acarrier_mat m n"
 and "xset xs. x < m"
  and "echelon_form_JNF A"
shows "echelon_form_JNF (Hermite_of_list_of_rows A xs)"
  using assms
proof (induct xs arbitrary: A rule: rev_induct)
  case Nil
  then show ?case by auto
next
  case (snoc x xs)
  have hyp: "echelon_form_JNF (Hermite_of_list_of_rows A xs)"
    by (rule snoc.hyps, insert snoc.prems, auto)
  have H_Axs: "(Hermite_of_list_of_rows A xs)  carrier_mat (dim_row A) (dim_col A)" 
    by (rule Hermite_of_list_of_rows)
  have "(Hermite_of_list_of_rows A (xs @ [x])) = Hermite_of_row_i (Hermite_of_list_of_rows A xs) x"
    using Hermite_of_list_of_rows_append by simp
  also have "echelon_form_JNF ..."
  proof (rule echelon_form_JNF_Hermite_of_row_i[OF hyp])
    show "x < dim_row (Hermite_of_list_of_rows A xs)" using snoc.prems H_Axs by auto
  qed
  finally show ?case .
qed




lemma HMA_Hermite_of_upt_row_i[transfer_rule]: 
  assumes "xs = [0..<i]"
    and "xset xs. x < CARD('m)"
  assumes "Mod_Type_Connect.HMA_M A (A':: int ^ 'n :: mod_type ^ 'm :: mod_type)" 
    and "echelon_form_JNF A"
  shows "Mod_Type_Connect.HMA_M (Hermite_of_list_of_rows A xs)
  (Hermite.Hermite_of_upt_row_i A' i ass_function_euclidean res_int)"
  using assms
proof (induct xs arbitrary: A A' i rule: rev_induct)
  case Nil
  have "i=0" using Nil by (metis le_0_eq upt_eq_Nil_conv)
  then show ?case using Nil unfolding Hermite_of_upt_row_i_def by auto
next
  case (snoc x xs)
  note xs_x_eq = snoc.prems(1)
  note all_xm = snoc.prems(2)
  note AA' = snoc.prems(3)
  note upt_A = snoc.prems(4)
  let ?x' = "(mod_type_class.from_nat x::'m)"
  have xm: "x < CARD('m)" using all_xm by auto
  have xx'[transfer_rule]: "Mod_Type_Connect.HMA_I x ?x'"
    unfolding Mod_Type_Connect.HMA_I_def using from_nat_not_eq xm by blast
  have last_i1: "last [0..<i] = i-1"
    by (metis append_is_Nil_conv last_upt list.simps(3) neq0_conv xs_x_eq upt.simps(1))
  have "last (xs @ [x]) = i-1" using xs_x_eq last_i1 by auto
  hence x_i1: "x = i-1" by auto
  have xs_eq: "xs = [0..<x]" using xs_x_eq x_i1
    by (metis add_diff_inverse_nat append_is_Nil_conv append_same_eq less_one list.simps(3)
        plus_1_eq_Suc upt_Suc upt_eq_Nil_conv)
  have list_rw: "[0..<i] = 0 #[1..<i]" 
    by (auto, metis append_is_Nil_conv list.distinct(2) upt_rec xs_x_eq)
  have 1: "Hermite_of_list_of_rows A (xs @ [x]) = Hermite_of_row_i (Hermite_of_list_of_rows A xs) x"
    unfolding Hermite_of_list_of_rows_append by auto
  let ?H_upt_HA = "Hermite.Hermite_of_upt_row_i"
  let ?H_HA = "Hermite.Hermite_of_row_i ass_function_euclidean res_int"
  have "(Hermite_of_upt_row_i A' i ass_function_euclidean res_int) = 
    foldl ?H_HA A' (map mod_type_class.from_nat [0..<i])"
    unfolding Hermite_of_upt_row_i_def by auto
  also have "... = foldl ?H_HA A' ((map mod_type_class.from_nat [0..<i-1])@[?x'])"
    by (metis list.simps(8) list.simps(9) map_append x_i1 xs_eq xs_x_eq)
  also have "... = foldl ?H_HA (?H_upt_HA A' (i - 1) ass_function_euclidean res_int) [?x']"
    unfolding foldl_append unfolding Hermite_of_upt_row_i_def[symmetric] by auto
  also have "... = ?H_HA (Hermite_of_upt_row_i A' (i - 1) ass_function_euclidean res_int) ?x'" by auto
  finally have 2: "?H_upt_HA A' i ass_function_euclidean res_int =
    ?H_HA (Hermite_of_upt_row_i A' (i - 1) ass_function_euclidean res_int) ?x'" .

  have hyp[transfer_rule]: "Mod_Type_Connect.HMA_M (Hermite_of_list_of_rows A xs)
              (Hermite_of_upt_row_i A' (i - 1) ass_function_euclidean res_int)"
    by (rule snoc.hyps[OF _ _ AA' upt_A], insert xs_eq x_i1 xm, auto)

  have upt_H_Axs:"upper_triangular' (Hermite_of_list_of_rows A xs)"
  proof (rule echelon_form_JNF_imp_upper_triangular, 
      rule echelon_form_JNF_Hermite_of_list_of_rows[OF _ _ upt_A])
    show "Acarrier_mat (CARD('m)) (CARD('n))"
      using Mod_Type_Connect.dim_col_transfer_rule
        Mod_Type_Connect.dim_row_transfer_rule snoc(4) by blast
    show "xset xs. x < CARD('m)" using all_xm by auto
  qed
  show ?case unfolding 1 2 
  by (rule HMA_Hermite_of_row_i[OF upt_H_Axs hyp xx'])
qed

(*This is the lemma that I will transfer to JNF to get the soundness*)
lemma Hermite_Hermite_of_upt_row_i:
  assumes a: "ass_function ass"
    and r: "res_function res"
    and eA: "echelon_form A"
  shows "Hermite (range ass) (λc. range (res c)) (Hermite_of_upt_row_i A (nrows A) ass res)" 
proof -
  let ?H = "(Hermite_of_upt_row_i A (nrows A) ass res)"  
  show ?thesis
  proof (rule Hermite_intro, auto)
    show "Complete_set_non_associates (range ass)"
      by (simp add: ass_function_Complete_set_non_associates a)
    show "Complete_set_residues (λc. range (res c))"
      by (simp add: r res_function_Complete_set_residues)
    show "echelon_form ?H"
      by (rule echelon_form_Hermite_of_upt_row_i[OF eA a r])  
    fix i
    assume i: "¬ is_zero_row i ?H" 
    show "?H $ i $ (LEAST n. ?H $ i $ n  0)  range ass"
    proof -
      have non_zero_i_eA: "¬ is_zero_row i A"
        using Hermite_of_upt_row_preserves_zero_rows[OF _ _ a r] i eA by blast   
      have least: "(LEAST n. ?H $h i $h n  0) = (LEAST n. A $h i $h n  0)"
        by (rule Hermite_of_upt_row_i_Least[OF non_zero_i_eA eA a r], simp)
      have "?H $ i $ (LEAST n. A $ i $ n  0)  range ass"
        by (rule Hermite_of_upt_row_i_in_range[OF non_zero_i_eA eA a r], auto)
      thus ?thesis unfolding least by auto
    qed
  next
    fix i j assume i: "¬ is_zero_row i ?H" and j: "j < i"
    show "?H $ j $ (LEAST n. ?H $ i $ n  0)
     range (res (?H $ i $ (LEAST n. ?H $ i $ n  0)))"
    proof -
      have non_zero_i_eA: "¬ is_zero_row i A"
        using Hermite_of_upt_row_preserves_zero_rows[OF _ _ a r] i eA by blast   
      have least: "(LEAST n. ?H $h i $h n  0) = (LEAST n. A $h i $h n  0)"
        by (rule Hermite_of_upt_row_i_Least[OF non_zero_i_eA eA a r], simp)
      have "?H $ j $ (LEAST n. A $ i $ n  0)  range (res (?H $ i $ (LEAST n. A $ i $ n  0)))"
        by (rule Hermite_of_upt_row_i_in_range_res[OF non_zero_i_eA eA a r _ _ j], auto)
      thus ?thesis unfolding least by auto
    qed
  qed
qed


lemma Hermite_of_row_i_0:
  "Hermite_of_row_i A 0 = A  Hermite_of_row_i A 0 = multrow 0 (- 1) A"
    by (cases "find_fst_non0_in_row 0 A", unfold Hermite_of_row_i_def, auto)

lemma Hermite_JNF_intro:
assumes 
"Complete_set_non_associates associates" "(Complete_set_residues res)" "echelon_form_JNF A"
 "(i<dim_row A. ¬ is_zero_row_JNF i A  A $$ (i, LEAST n. A $$ (i, n)  0)  associates)"
 "(i<dim_row A. ¬ is_zero_row_JNF i A  (j. j<i  A $$ (j, (LEAST n. A $$ (i, n)  0)) 
      res (A $$ (i,(LEAST n. A $$ (i,n)  0)))))"
shows "Hermite_JNF associates res A"
  using assms unfolding Hermite_JNF_def by auto

lemma least_multrow:
  assumes "A  carrier_mat m n" and "i<m" and eA: "echelon_form_JNF A"
  assumes ia: "ia < dim_row A" and nz_ia_mrA: "¬ is_zero_row_JNF ia (multrow i (- 1) A)"
  shows "(LEAST n. multrow i (- 1) A $$ (ia, n)  0) = (LEAST n. A $$ (ia, n)  0)"
proof (rule Least_equality)
  have nz_ia_A: "¬ is_zero_row_JNF ia A" using nz_ia_mrA ia by auto
  have Least_Aian_n: "(LEAST n. A $$ (ia, n)  0) < dim_col A"
    by (smt dual_order.strict_trans is_zero_row_JNF_def not_less_Least not_less_iff_gr_or_eq nz_ia_A)
  show "multrow i (- 1) A $$ (ia, LEAST n. A $$ (ia, n)  0)  0"
    by (smt LeastI Least_Aian_n class_cring.cring_simprules(22) equation_minus_iff ia
        index_mat_multrow(1) is_zero_row_JNF_def mult_minus1 nz_ia_A)
  show " y. multrow i (- 1) A $$ (ia, y)  0  (LEAST n. A $$ (ia, n)  0)  y"
    by (metis (mono_tags, lifting) Least_Aian_n class_cring.cring_simprules(22) ia 
        index_mat_multrow(1) leI mult_minus1 order.strict_trans wellorder_Least_lemma(2))
qed


lemma Hermite_Hermite_of_row_i:
  assumes A: "A  carrier_mat 1 n"
  shows "Hermite_JNF (range ass_function_euclidean) (λc. range (res_int c)) (Hermite_of_row_i A 0)"
proof (rule Hermite_JNF_intro)
  show "Complete_set_non_associates (range ass_function_euclidean)"   
    using ass_function_Complete_set_non_associates ass_function_euclidean by blast
  show "Complete_set_residues (λc. range (res_int c))"
    using res_function_Complete_set_residues res_function_res_int by blast
  show "echelon_form_JNF (HNF_Mod_Det_Algorithm.Hermite_of_row_i A 0)"
    by (metis (full_types) assms carrier_matD(1) echelon_form_JNF_Hermite_of_row_i
        echelon_form_JNF_def less_one not_less_zero)
  let ?H = "Hermite_of_row_i A 0"
  show "i<dim_row ?H. ¬ is_zero_row_JNF i ?H 
       ?H $$ (i, LEAST n. ?H $$ (i, n)  0)  range ass_function_euclidean"
  proof (auto)
    fix i assume i: "i<dim_row ?H" and nz_iH: "¬ is_zero_row_JNF i ?H"
    have nz_iA: "¬ is_zero_row_JNF i A"
      by (metis (full_types) Hermite_of_row_i Hermite_of_row_i_0 carrier_matD(1)
          i is_zero_row_JNF_multrow nz_iH)
    have "?H $$ (i, LEAST n. ?H $$ (i, n)  0)  0"
    proof (cases "find_fst_non0_in_row 0 A")
      case None
       then show ?thesis using nz_iH unfolding Hermite_of_row_i_def
         by (smt HNF_Mod_Det_Algorithm.Hermite_of_row_i_def upper_triangular'_def assms 
             carrier_matD(1) find_fst_non0_in_row_None i less_one not_less_zero option.simps(4))
    next
      case (Some a)
      have upA: "upper_triangular' A" using A unfolding upper_triangular'_def by auto
      have eA: "echelon_form_JNF A" by (metis A Suc_1 echelon_form_JNF_1xn lessI)
      have i0: "i=0" using Hermite_of_row_i[of A 0] A i by auto        
      have Aia: "A $$ (i,a)  0" and a0: "0  a" and an: "a<n"
        using i0 Some assms find_fst_non0_in_row by auto+
      have l: "(LEAST n. A $$ (i, n)  0) = (LEAST n.  multrow 0 (- 1) A $$ (i, n)  0)"
        by (rule least_multrow[symmetric, OF A _ eA _], insert nz_iA i A i0, auto)
      have a1: "a = (LEAST n. A $$ (i, n)  0)"
        by (rule find_fst_non0_in_row_LEAST[OF A upA], insert Some i0, auto)
      hence a2: "a = (LEAST n.  multrow 0 (- 1) A $$ (i, n)  0)" unfolding l by simp
      have m1: "multrow 0 (- 1) A $$ (i, LEAST n. multrow 0 (- 1) A $$ (i, n)  0) 
          = (- 1) * A $$ (i, LEAST n. A $$ (i, n)  0)"
        by (metis Hermite_of_row_i_0 a1 a2 an assms carrier_matD(2) i i0 index_mat_multrow(1,4))
      then show ?thesis using nz_iH Some a1 Aia a2 i0 unfolding Hermite_of_row_i_def by auto 
    qed
    thus "?H $$ (i, LEAST n. ?H $$ (i, n)  0)  range ass_function_euclidean"
      using ass_function_int ass_function_int_UNIV by auto
    qed
    show "i<dim_row ?H. ¬ is_zero_row_JNF i ?H  (j<i. ?H $$ (j, LEAST n. ?H $$ (i, n)  0)
     range (res_int (?H $$ (i, LEAST n. ?H $$ (i, n)  0))))"
      using Hermite_of_row_i[of A 0] A by auto
  qed
  
lemma Hermite_of_row_i_0_eq_0:
  assumes A: "Acarrier_mat m n" and i: "i>0" and eA: "echelon_form_JNF A" and im: "i<m"
    and n0: "0<n"
  shows "Hermite_of_row_i A 0 $$ (i, 0) = 0"
proof -
  have Ai0: "A $$ (i, 0) = 0" by (rule echelon_form_JNF_first_column_0[OF eA A i im n0]) 
  show ?thesis
  proof (cases "find_fst_non0_in_row 0 A")
    case None  
    thus ?thesis using Ai0 unfolding Hermite_of_row_i_def by auto 
  next
    case (Some a)
    have "A $$ (0, a)  0"  and a0: "0  a" and an: "a<n"
      using find_fst_non0_in_row[OF A Some] A by auto
    then show ?thesis using Some Ai0 A an a0 im unfolding Hermite_of_row_i_def mat_multrow_def by auto
  qed
qed

  

lemma Hermite_Hermite_of_row_i_mx1:
  assumes A: "A  carrier_mat m 1" and eA: "echelon_form_JNF A"
  shows "Hermite_JNF (range ass_function_euclidean) (λc. range (res_int c)) (Hermite_of_row_i A 0)"
proof (rule Hermite_JNF_intro)
  show "Complete_set_non_associates (range ass_function_euclidean)"   
    using ass_function_Complete_set_non_associates ass_function_euclidean by blast
  show "Complete_set_residues (λc. range (res_int c))"
    using res_function_Complete_set_residues res_function_res_int by blast
  have H: "Hermite_of_row_i A 0 : carrier_mat m 1" using A Hermite_of_row_i[of A] by auto
  have upA: "upper_triangular' A"
    by (simp add: eA echelon_form_JNF_imp_upper_triangular)
  show eH: "echelon_form_JNF (Hermite_of_row_i A 0)"
  proof (rule echelon_form_JNF_mx1[OF H])
    show "i{1..<m}. HNF_Mod_Det_Algorithm.Hermite_of_row_i A 0 $$ (i, 0) = 0"
      using Hermite_of_row_i_0_eq_0 assms by auto
  qed (simp)
  let ?H = "Hermite_of_row_i A 0"
  show "i<dim_row ?H. ¬ is_zero_row_JNF i ?H 
       ?H $$ (i, LEAST n. ?H $$ (i, n)  0)  range ass_function_euclidean"
  proof (auto)
    fix i assume i: "i<dim_row ?H" and nz_iH: "¬ is_zero_row_JNF i ?H"
    have nz_iA: "¬ is_zero_row_JNF i A"
      by (metis (full_types) Hermite_of_row_i Hermite_of_row_i_0 carrier_matD(1)
          i is_zero_row_JNF_multrow nz_iH)    
    have "?H $$ (i, LEAST n. ?H $$ (i, n)  0)  0"
    proof (cases "find_fst_non0_in_row 0 A")
      case None
      have "is_zero_row_JNF i A"
        by (metis H upper_triangular'_def None assms(1) carrier_matD find_fst_non0_in_row_None
            i is_zero_row_JNF_def less_one linorder_neqE_nat not_less0 upA)
       then show ?thesis using nz_iH None unfolding Hermite_of_row_i_def by auto
     next
      case (Some a)
      have Aia: "A $$ (0,a)  0" and a0: "0  a" and an: "a<1"
        using find_fst_non0_in_row[OF A Some] A by auto  
      have nz_j_mA: "is_zero_row_JNF j (multrow 0 (- 1) A)" if j0: "j>0" and jm: "j<m" for j 
        unfolding is_zero_row_JNF_def using A j0 jm upA by auto
      show ?thesis
      proof (cases "i=0")
        case True
        then show ?thesis
          using nz_iH Some nz_j_mA A H i Aia an unfolding Hermite_of_row_i_def by auto
      next
        case False
        have nz_iA: "is_zero_row_JNF i A"
          by (metis False H Hermite_of_row_i_0 carrier_matD(1) i is_zero_row_JNF_multrow not_gr0 nz_iH nz_j_mA)
        hence "is_zero_row_JNF i (multrow 0 (- 1) A)" using A H i by auto
        then show ?thesis using nz_iH Some nz_j_mA False nz_iA 
          unfolding Hermite_of_row_i_def by fastforce
      qed
    qed
    thus "?H $$ (i, LEAST n. ?H $$ (i, n)  0)  range ass_function_euclidean"
      using ass_function_int ass_function_int_UNIV by auto
    qed
    show "i<dim_row ?H. ¬ is_zero_row_JNF i ?H  (j<i. ?H $$ (j, LEAST n. ?H $$ (i, n)  0)
     range (res_int (?H $$ (i, LEAST n. ?H $$ (i, n)  0))))"
    proof auto
      fix i j assume i: "i<dim_row ?H" and nz_iH: "¬ is_zero_row_JNF i ?H" and ji: "j<i"
      have "i=0"
        by (metis H upper_triangular'_def One_nat_def nz_iH eH i carrier_matD(2) nat_neq_iff
            echelon_form_JNF_imp_upper_triangular is_zero_row_JNF_def less_Suc0 not_less_zero)
      thus "?H $$ (j, LEAST n. ?H $$ (i, n)  0)
            range (res_int (?H $$ (i, LEAST n. ?H $$ (i, n)  0)))" using ji by auto
    qed
qed


lemma Hermite_of_list_of_rows_1xn:
  assumes A: "A  carrier_mat 1 n"
    and eA: "echelon_form_JNF A" 
    and x: "x  set xs. x < 1" and xs: "xs[]"
  shows "Hermite_JNF (range ass_function_euclidean) 
  (λc. range (res_int c)) (Hermite_of_list_of_rows A xs)"
  using x xs
proof (induct xs rule: rev_induct)
  case Nil
  then show ?case by auto
next
  case (snoc x xs)
  have x0: "x=0" using snoc.prems by auto
  show ?case 
  proof (cases "xs = []")
    case True    
    have "Hermite_of_list_of_rows A (xs @ [x]) = Hermite_of_row_i A 0"
      unfolding Hermite_of_list_of_rows_append x0 using True by auto
    then show ?thesis using Hermite_Hermite_of_row_i[OF A] by auto
  next
    case False
    have x0: "x=0" using snoc.prems by auto
    have hyp: "Hermite_JNF (range ass_function_euclidean) 
      (λc. range (res_int c)) (Hermite_of_list_of_rows A xs)"
        by (rule snoc.hyps, insert snoc.prems False, auto)
    have "Hermite_of_list_of_rows A (xs @ [x]) = Hermite_of_row_i (Hermite_of_list_of_rows A xs) 0"
      unfolding Hermite_of_list_of_rows_append hyp x0 ..
    thus ?thesis
      by (metis A Hermite_Hermite_of_row_i Hermite_of_list_of_rows carrier_matD(1))
  qed
qed


lemma Hermite_of_row_i_id_mx1:
  assumes H': "Hermite_JNF (range ass_function_euclidean) (λc. range (res_int c)) A"
    and x: "x<dim_row A" and A: "Acarrier_mat m 1"
shows "Hermite_of_row_i A x = A"  
proof (cases "find_fst_non0_in_row x A")
  case None
  then show ?thesis unfolding Hermite_of_row_i_def by auto
next
  case (Some a)
  have eH: "echelon_form_JNF A" using H' unfolding Hermite_JNF_def by simp
  have ut_A: "upper_triangular' A" by (simp add: eH echelon_form_JNF_imp_upper_triangular)
  have a_least: "a = (LEAST n. A $$ (x,n)  0)" 
    by (rule find_fst_non0_in_row_LEAST[OF _ ut_A Some], insert x, auto)
  have Axa: "A $$ (x, a)  0" and xa: "xa" and a: "a<dim_col A"
    using find_fst_non0_in_row[OF A Some] unfolding a_least by auto
  have nz_xA: "¬ is_zero_row_JNF x A" using Axa xa x a unfolding is_zero_row_JNF_def by blast
  have a0: "a = 0" using a A by auto
  have x0: "x=0" using echelon_form_JNF_first_column_0[OF eH A] Axa a0 xa by blast  
  have "A $$ (x, a)  (range ass_function_euclidean)" 
    using nz_xA H' x unfolding a_least unfolding Hermite_JNF_def by auto
  hence "A $$ (x, a) > 0" using Axa unfolding image_def ass_function_euclidean_def by auto
  then show ?thesis unfolding Hermite_of_row_i_def using Some x0 by auto
qed

lemma Hermite_of_row_i_id_mx1':
  assumes eA: "echelon_form_JNF A"
    and x: "x<dim_row A" and A: "Acarrier_mat m 1"
shows "Hermite_of_row_i A x = A  Hermite_of_row_i A x = multrow 0 (- 1) A" 
proof (cases "find_fst_non0_in_row x A")
  case None
  then show ?thesis unfolding Hermite_of_row_i_def by auto
next
  case (Some a)
  have ut_A: "upper_triangular' A" by (simp add: eA echelon_form_JNF_imp_upper_triangular)
  have a_least: "a = (LEAST n. A $$ (x,n)  0)" 
    by (rule find_fst_non0_in_row_LEAST[OF _ ut_A Some], insert x, auto)
  have Axa: "A $$ (x, a)  0" and xa: "xa" and a: "a<dim_col A"
    using find_fst_non0_in_row[OF A Some] unfolding a_least by auto
  have nz_xA: "¬ is_zero_row_JNF x A" using Axa xa x a unfolding is_zero_row_JNF_def by blast
  have a0: "a = 0" using a A by auto
  have x0: "x=0" using echelon_form_JNF_first_column_0[OF eA A] Axa a0 xa by blast
  show ?thesis by (cases "A $$(x,a)>0", unfold Hermite_of_row_i_def, insert Some x0, auto)
qed


lemma Hermite_of_list_of_rows_mx1:
  assumes A: "A  carrier_mat m 1"
    and eA: "echelon_form_JNF A" 
    and x: "x  set xs. x < m" and xs: "xs=[0..<i]" and i: "i>0"
  shows "Hermite_JNF (range ass_function_euclidean) 
  (λc. range (res_int c)) (Hermite_of_list_of_rows A xs)"
  using x xs i
proof (induct xs arbitrary: i rule: rev_induct)
  case Nil
  then show ?case by (metis neq0_conv not_less upt_eq_Nil_conv)
next
  case (snoc x xs)
  note all_n_xs_x = snoc.prems(1)
  note xs_x = snoc.prems(2)
  note i0 = snoc.prems(3)
  have i_list_rw:"[0..<i] = [0..<i-1] @ [i-1]" using i0 less_imp_Suc_add by fastforce
  hence xs: "xs = [0..<i-1]" using xs_x by force
  hence x: "x=i-1" using i_list_rw xs_x by auto
  have H: "Hermite_of_list_of_rows A xs  carrier_mat m 1"
    using A Hermite_of_list_of_rows[of A xs] by auto
  show ?case
  proof (cases "i-1=0")
    case True
    hence xs_empty: "xs = []" using xs by auto
    have *: "Hermite_of_list_of_rows A (xs @ [x]) = Hermite_of_row_i A 0"
      unfolding Hermite_of_list_of_rows_append xs_empty x True by simp    
    show ?thesis unfolding * by (rule Hermite_Hermite_of_row_i_mx1[OF A eA])
  next
    case False          
    have hyp: "Hermite_JNF (range ass_function_euclidean) 
      (λc. range (res_int c)) (Hermite_of_list_of_rows A xs)"
      by (rule snoc.hyps[OF _ xs], insert False all_n_xs_x, auto)
    have "Hermite_of_list_of_rows A (xs @ [x]) 
        = Hermite_of_row_i (Hermite_of_list_of_rows A xs) x" 
      unfolding Hermite_of_list_of_rows_append ..
    also have "... = (Hermite_of_list_of_rows A xs)"
      by (rule Hermite_of_row_i_id_mx1[OF hyp _ H], insert snoc.prems H x, auto)
    finally show ?thesis using hyp by auto
  qed
qed



lemma invertible_Hermite_of_list_of_rows_1xn:
  assumes "A  carrier_mat 1 n"
  shows "P. P  carrier_mat 1 1  invertible_mat P  Hermite_of_list_of_rows A [0..<1] = P * A"
proof -
  let ?H = "Hermite_of_list_of_rows A [0..<1]"
  have "?H = Hermite_of_row_i A 0" by auto 
  hence H_or: "?H = A  ?H = multrow 0 (- 1) A"
    using Hermite_of_row_i_0 by simp
  show ?thesis
  proof (cases "?H = A")
    case True
    then show ?thesis
      by (metis assms invertible_mat_one left_mult_one_mat one_carrier_mat)
  next
    case False
    hence H_mr: "?H = multrow 0 (- 1) A" using H_or by simp
    let ?M = "multrow_mat 1 0 (-1)::int mat"
    show ?thesis
    proof (rule exI[of _ "?M"])
      have "?M  carrier_mat 1 1" by auto
      moreover have "invertible_mat ?M"
        by (metis calculation det_multrow_mat det_one dvd_mult_right invertible_iff_is_unit_JNF
            invertible_mat_one one_carrier_mat square_eq_1_iff zero_less_one_class.zero_less_one)
      moreover have "?H= ?M * A"
        by (metis H_mr assms multrow_mat)      
      ultimately show "?M  carrier_mat 1 1  invertible_mat (?M) 
   Hermite_of_list_of_rows A [0..<1] = ?M * A" by blast
    qed
  qed
qed



lemma invertible_Hermite_of_list_of_rows_mx1':
  assumes A: "A  carrier_mat m 1" and eA: "echelon_form_JNF A"
    and xs_i: "xs = [0..<i]" and xs_m: "xset xs. x < m" and i: "i>0"
  shows "P. P  carrier_mat m m  invertible_mat P  Hermite_of_list_of_rows A xs = P * A"
  using xs_i xs_m i
proof (induct xs arbitrary: i rule: rev_induct)
  case Nil
  then show ?case by (metis diff_zero length_upt list.size(3) zero_order(3))
next
  case (snoc x xs)
  note all_n_xs_x = snoc.prems(2)
  note xs_x = snoc.prems(1)
  note i0 = snoc.prems(3)
  have i_list_rw:"[0..<i] = [0..<i-1] @ [i-1]" using i0 less_imp_Suc_add by fastforce
  hence xs: "xs = [0..<i-1]" using xs_x by force
  hence x: "x=i-1" using i_list_rw xs_x by auto
  have H: "Hermite_of_list_of_rows A xs  carrier_mat m 1"
    using A Hermite_of_list_of_rows[of A xs] by auto
  show ?case
  proof (cases "i-1=0")
    case True
    hence xs_empty: "xs = []" using xs by auto
    let ?H = "Hermite_of_list_of_rows A (xs @ [x])"
    have *: "Hermite_of_list_of_rows A (xs @ [x]) = Hermite_of_row_i A 0"
      unfolding Hermite_of_list_of_rows_append xs_empty x True by simp  
    hence H_or: "?H = A  ?H = multrow 0 (- 1) A" using Hermite_of_row_i_0 by simp
    thus ?thesis
    proof (cases "?H=A")
      case True
      then show ?thesis unfolding * 
        by (metis A invertible_mat_one left_mult_one_mat one_carrier_mat)
    next
      case False
      hence H_mr: "?H = multrow 0 (- 1) A" using H_or by simp    
      let ?M = "multrow_mat m 0 (-1)::int mat"
    show ?thesis 
    proof (rule exI[of _ "?M"])
      have "?M  carrier_mat m m" by auto
      moreover have "invertible_mat ?M"
        by (metis (full_types) det_multrow_mat dvd_mult_right invertible_iff_is_unit_JNF
            invertible_mat_zero more_arith_simps(10) mult_minus1_right multrow_mat_carrier neq0_conv)
      moreover have "?H = ?M * A" unfolding H_mr using A multrow_mat by blast            
      ultimately show "?M  carrier_mat m m  invertible_mat ?M  ?H = ?M * A" by blast
    qed
  qed
  next
    case False
    let ?A = "(Hermite_of_list_of_rows A xs)"
    have A': "?A  carrier_mat m 1" using A Hermite_of_list_of_rows[of A xs] by simp
    have hyp: "P. P  carrier_mat m m  invertible_mat P  Hermite_of_list_of_rows A xs = P * A"
      by (rule snoc.hyps[OF xs], insert False all_n_xs_x, auto)
    have rw: "Hermite_of_list_of_rows A (xs @ [x]) 
        = Hermite_of_row_i (Hermite_of_list_of_rows A xs) x" 
      unfolding Hermite_of_list_of_rows_append ..
    have *: "Hermite_of_row_i ?A x = ?A  Hermite_of_row_i ?A x = multrow 0 (- 1) ?A"
    proof (rule Hermite_of_row_i_id_mx1'[OF _ _ A'])
      show "echelon_form_JNF ?A"
        using A eA echelon_form_JNF_Hermite_of_list_of_rows snoc(3) by auto
      show "x < dim_row ?A" using A' x i A by (simp add: snoc(3))
    qed
    show ?thesis
    proof (cases "Hermite_of_row_i ?A x = ?A")
    case True
      then show ?thesis 
        by (simp add: hyp rw)
    next
      case False
      let ?M = "multrow_mat m 0 (-1)::int mat"
      obtain P where P: "P  carrier_mat m m" 
        and inv_P: "invertible_mat P" and H_PA: "Hermite_of_list_of_rows A xs = P * A"
        using hyp by auto
      have M: "?M  carrier_mat m m" by auto
      have inv_M: "invertible_mat ?M"
        by (metis (full_types) det_multrow_mat dvd_mult_right invertible_iff_is_unit_JNF
            invertible_mat_zero more_arith_simps(10) mult_minus1_right multrow_mat_carrier neq0_conv)
      have H_MA': "Hermite_of_row_i ?A x = ?M * ?A" using False * H multrow_mat by metis
      have inv_MP: "invertible_mat (?M*P)" using M inv_M P inv_P invertible_mult_JNF by blast
      moreover have MP: "(?M*P)  carrier_mat m m" using M P by fastforce
      moreover have "Hermite_of_list_of_rows A (xs @ [x]) = (?M*P) * A"
        by (metis A H_MA' H_PA M P assoc_mult_mat rw)  
      ultimately show ?thesis by blast
    qed  
  qed
qed


corollary invertible_Hermite_of_list_of_rows_mx1:
  assumes "A  carrier_mat m 1" and eA: "echelon_form_JNF A"
  shows "P. P  carrier_mat m m  invertible_mat P  Hermite_of_list_of_rows A [0..<m] = P * A"
proof (cases "m=0")
  case True
  then show ?thesis 
    by (auto, metis assms(1) invertible_mat_one left_mult_one_mat one_carrier_mat)
next
  case False
  then show ?thesis using invertible_Hermite_of_list_of_rows_mx1' assms by simp
qed
  

lemma Hermite_of_list_of_rows_mx0:
  assumes A: "A  carrier_mat m 0"
  and xs: "xs = [0..<i]" and x: "x set xs. x < m"
shows "Hermite_of_list_of_rows A xs = A"
  using xs x
proof (induct xs arbitrary: i rule: rev_induct)
  case Nil
  then show ?case by auto
next
  case (snoc x xs)    
  note all_n_xs_x = snoc.prems(2)
  note xs_x = snoc.prems(1)
  have i0: "i>0" using neq0_conv snoc(2) by fastforce
  have i_list_rw:"[0..<i] = [0..<i-1] @ [i-1]" using i0 less_imp_Suc_add by fastforce
  hence xs: "xs = [0..<i-1]" using xs_x by force
  hence x: "x=i-1" using i_list_rw xs_x by auto
  have H: "Hermite_of_list_of_rows A xs  carrier_mat m 0"
    using A Hermite_of_list_of_rows[of A xs] by auto
  define A' where "A' = (Hermite_of_list_of_rows A xs)"
  have A'A: "A' = A" by (unfold A'_def, rule snoc.hyps, insert snoc.prems xs, auto)
  have "Hermite_of_list_of_rows A (xs @ [x]) = Hermite_of_row_i A' x"
    using Hermite_of_list_of_rows_append A'_def by auto
  also have "... = A"
  proof (cases "find_fst_non0_in_row x A'")
    case None
    then show ?thesis unfolding Hermite_of_row_i_def using A'A by auto
    next
      case (Some a)
    then show ?thesis
      by (metis (full_types) A'A A carrier_matD(2) find_fst_non0_in_row(3) zero_order(3))
  qed
  finally show ?case .
qed


text ‹Again, we move more lemmas from HOL Analysis (with mod-type restrictions) to the JNF matrix
representation.›

(*
The following lemmas will be transferred from HOL Analysis to JNF:
thm Hermite_Hermite_of_upt_row_i
thm invertible_Hermite_of_upt_row_i
*)

context
begin

private lemma Hermite_Hermite_of_list_of_rows_mod_type:
  fixes A::"int mat"
  assumes "A  carrier_mat CARD('m::mod_type) CARD('n::mod_type)"
  assumes eA: "echelon_form_JNF A"
shows "Hermite_JNF (range ass_function_euclidean) 
  (λc. range (res_int c)) (Hermite_of_list_of_rows A [0..<CARD('m)])"
proof -
  define A' where "A' = (Mod_Type_Connect.to_hmam A :: int ^'n :: mod_type ^'m :: mod_type)"
  have AA'[transfer_rule]: "Mod_Type_Connect.HMA_M A A'"
    unfolding Mod_Type_Connect.HMA_M_def using assms A'_def by auto 
  have eA'[transfer_rule]: "echelon_form A'" using eA by transfer
  have [transfer_rule]: "Mod_Type_Connect.HMA_M (Hermite_of_list_of_rows A [0..<CARD('m)]) 
  (Hermite_of_upt_row_i A' (CARD('m)) ass_function_euclidean res_int)"
    by (rule HMA_Hermite_of_upt_row_i[OF _ _ AA' eA], auto)
  have [transfer_rule]: " (range ass_function_euclidean) =  (range ass_function_euclidean)" ..
  have [transfer_rule]: "(λc. range (res_int c)) = (λc. range (res_int c))" ..
  have n: "CARD('m) = nrows A'" using AA' unfolding nrows_def by auto
  have "Hermite (range ass_function_euclidean) (λc. range (res_int c)) 
  (Hermite_of_upt_row_i A' (CARD('m)) ass_function_euclidean res_int)"
    by (unfold n, rule Hermite_Hermite_of_upt_row_i[OF ass_function_euclidean res_function_res_int eA'])    
  thus ?thesis by transfer
qed 

private lemma invertible_Hermite_of_list_of_rows_mod_type:
  fixes A::"int mat"
  assumes "A  carrier_mat CARD('m::mod_type) CARD('n::mod_type)"
  assumes eA: "echelon_form_JNF A"
  shows "P. P  carrier_mat CARD('m) CARD('m)  
    invertible_mat P  Hermite_of_list_of_rows A [0..<CARD('m)] = P * A"
proof -
  define A' where "A' = (Mod_Type_Connect.to_hmam A :: int ^'n :: mod_type ^'m :: mod_type)"
  have AA'[transfer_rule]: "Mod_Type_Connect.HMA_M A A'"
    unfolding Mod_Type_Connect.HMA_M_def using assms A'_def by auto 
  have eA'[transfer_rule]: "echelon_form A'" using eA by transfer
  have [transfer_rule]: "Mod_Type_Connect.HMA_M (Hermite_of_list_of_rows A [0..<CARD('m)]) 
  (Hermite_of_upt_row_i A' (CARD('m)) ass_function_euclidean res_int)"
    by (rule HMA_Hermite_of_upt_row_i[OF _ _ AA' eA], auto)
  have [transfer_rule]: " (range ass_function_euclidean) =  (range ass_function_euclidean)" ..
  have [transfer_rule]: "(λc. range (res_int c)) = (λc. range (res_int c))" ..
  have n: "CARD('m) = nrows A'" using AA' unfolding nrows_def by auto
  have "P. invertible P  Hermite_of_upt_row_i A' (CARD('m)) ass_function_euclidean res_int 
      = P ** A'" by (rule invertible_Hermite_of_upt_row_i[OF ass_function_euclidean])
  thus ?thesis by (transfer, auto)
qed


private lemma Hermite_Hermite_of_list_of_rows_nontriv_mod_ring:
  fixes A::"int mat"
  assumes "A  carrier_mat CARD('m::nontriv mod_ring) CARD('n::nontriv mod_ring)"
  assumes eA: "echelon_form_JNF A"
shows "Hermite_JNF (range ass_function_euclidean) 
  (λc. range (res_int c)) (Hermite_of_list_of_rows A [0..<CARD('m)])"
using assms Hermite_Hermite_of_list_of_rows_mod_type by (smt CARD_mod_ring) 

private lemma invertible_Hermite_of_list_of_rows_nontriv_mod_ring:
  fixes A::"int mat"
  assumes "A  carrier_mat CARD('m::nontriv mod_ring) CARD('n::nontriv mod_ring)"
  assumes eA: "echelon_form_JNF A"
  shows "P. P  carrier_mat CARD('m) CARD('m)  
    invertible_mat P  Hermite_of_list_of_rows A [0..<CARD('m)] = P * A"
using assms invertible_Hermite_of_list_of_rows_mod_type by (smt CARD_mod_ring) 


(*We internalize both sort constraints in one step*)
lemmas Hermite_Hermite_of_list_of_rows_nontriv_mod_ring_internalized = 
  Hermite_Hermite_of_list_of_rows_nontriv_mod_ring[unfolded CARD_mod_ring, 
      internalize_sort "'m::nontriv", internalize_sort "'b::nontriv"]

lemmas invertible_Hermite_of_list_of_rows_nontriv_mod_ring_internalized = 
  invertible_Hermite_of_list_of_rows_nontriv_mod_ring[unfolded CARD_mod_ring, 
      internalize_sort "'m::nontriv", internalize_sort "'b::nontriv"]


context
  fixes m::nat and n::nat
  assumes local_typedef1: "(Rep :: ('b  int)) Abs. type_definition Rep Abs {0..<m :: int}"
  assumes local_typedef2: "(Rep :: ('c  int)) Abs. type_definition Rep Abs {0..<n :: int}"
  and m: "m>1"
  and n: "n>1"
begin

lemma Hermite_Hermite_of_list_of_rows_nontriv_mod_ring_aux:
 fixes A::"int mat"
   assumes "A  carrier_mat m n"
  assumes eA: "echelon_form_JNF A"
shows "Hermite_JNF (range ass_function_euclidean) 
  (λc. range (res_int c)) (Hermite_of_list_of_rows A [0..<m])"
  using Hermite_Hermite_of_list_of_rows_nontriv_mod_ring_internalized
    [OF type_to_set2(1)[OF local_typedef1 local_typedef2] 
        type_to_set1(1)[OF local_typedef1 local_typedef2]]
  using assms 
  using type_to_set1(2) local_typedef1 local_typedef2 n m by metis 



lemma invertible_Hermite_of_list_of_rows_nontriv_mod_ring_aux:
  fixes A::"int mat"
  assumes "A  carrier_mat m n"
  assumes eA: "echelon_form_JNF A"
  shows "P. P  carrier_mat m m  invertible_mat P  Hermite_of_list_of_rows A [0..<m] = P * A"
using invertible_Hermite_of_list_of_rows_nontriv_mod_ring_internalized
    [OF type_to_set2(1)[OF local_typedef1 local_typedef2] 
        type_to_set1(1)[OF local_typedef1 local_typedef2]]
  using assms 
  using type_to_set1(2) local_typedef1 local_typedef2 n m by metis 
end


(*Canceling the first local type definitions*)
context
begin

(*Canceling the first*)
private lemma invertible_Hermite_of_list_of_rows_cancelled_first:
  "Rep Abs. type_definition Rep Abs {0..<int n} 
   1 < m  1 < n  A  carrier_mat m n  echelon_form_JNF A 
   P. P  carrier_mat m m  invertible_mat P  Hermite_of_list_of_rows A [0..<m] = P * A"
  using invertible_Hermite_of_list_of_rows_nontriv_mod_ring_aux[cancel_type_definition, of m n A]
  by auto  

(*Canceling the second*)
private lemma invertible_Hermite_of_list_of_rows_cancelled_both:
  "1 < m  1 < n  A  carrier_mat m n  echelon_form_JNF A 
   P. P  carrier_mat m m  invertible_mat P  Hermite_of_list_of_rows A [0..<m] = P * A"
  using invertible_Hermite_of_list_of_rows_cancelled_first[cancel_type_definition, of n m A] by simp


(*Canceling the first*)

private lemma Hermite_Hermite_of_list_of_rows_cancelled_first:
"Rep Abs. type_definition Rep Abs {0..<int n} 
  1 < m 
  1 < n 
  A  carrier_mat m n 
  echelon_form_JNF A 
   Hermite_JNF (range ass_function_euclidean) (λc. range (res_int c)) (Hermite_of_list_of_rows A [0..<m])"
  using Hermite_Hermite_of_list_of_rows_nontriv_mod_ring_aux[cancel_type_definition, of m n A]
  by auto  

(*Canceling the second*)
private lemma Hermite_Hermite_of_list_of_rows_cancelled_both:
"1 < m 
  1 < n 
  A  carrier_mat m n 
  echelon_form_JNF A 
   Hermite_JNF (range ass_function_euclidean) (λc. range (res_int c)) (Hermite_of_list_of_rows A [0..<m])"
  using Hermite_Hermite_of_list_of_rows_cancelled_first[cancel_type_definition, of n m A] by simp


(*The final results in JNF*)

lemma Hermite_Hermite_of_list_of_rows':
 fixes A::"int mat"
  assumes "A  carrier_mat m n"
    and "echelon_form_JNF A"  
  and "1 < m" and "1 < n" (*Required from the mod_type restrictions*)
shows "Hermite_JNF (range ass_function_euclidean) 
  (λc. range (res_int c)) (Hermite_of_list_of_rows A [0..<m])"  
  using Hermite_Hermite_of_list_of_rows_cancelled_both assms by auto

corollary Hermite_Hermite_of_list_of_rows:
 fixes A::"int mat"
  assumes A: "A  carrier_mat m n"
    and eA: "echelon_form_JNF A"  
shows "Hermite_JNF (range ass_function_euclidean) 
  (λc. range (res_int c)) (Hermite_of_list_of_rows A [0..<m])"
proof (cases "m=0  n=0")
  case True
  then show ?thesis 
    by (auto, metis Hermite_Hermite_of_row_i Hermite_JNF_def A eA carrier_matD(1) one_carrier_mat zero_order(3))   
     (metis Hermite_Hermite_of_row_i Hermite_JNF_def Hermite_of_list_of_rows A carrier_matD(2) 
       echelon_form_mx0 is_zero_row_JNF_def mat_carrier zero_order(3))
next
  case False note not_m0_or_n0 = False
  show ?thesis
  proof (cases "m=1  n=1")
    case True
    then show ?thesis
      by (metis False Hermite_of_list_of_rows_1xn Hermite_of_list_of_rows_mx1 A eA 
          atLeastLessThan_iff linorder_not_less neq0_conv set_upt upt_eq_Nil_conv)
  next
    case False
    show ?thesis
      by (rule Hermite_Hermite_of_list_of_rows'[OF A eA], insert not_m0_or_n0 False, auto)
  qed
qed

lemma invertible_Hermite_of_list_of_rows:
  assumes A: "A  carrier_mat m n"
  and eA: "echelon_form_JNF A"
shows "P. P  carrier_mat m m  invertible_mat P  Hermite_of_list_of_rows A [0..<m] = P * A"
proof (cases "m=0  n=0")
  case True
  have *: "Hermite_of_list_of_rows A [0..<m] = A" if n: "n=0"
    by (rule Hermite_of_list_of_rows_mx0, insert A n, auto)
  show ?thesis using True
    by (auto, metis assms(1) invertible_mat_one left_mult_one_mat one_carrier_mat)
       (metis (full_types) "*" assms(1) invertible_mat_one left_mult_one_mat one_carrier_mat)
next
  case False note mn = False
  show ?thesis
  proof (cases "m=1  n=1")
    case True
    then show ?thesis 
      using A eA invertible_Hermite_of_list_of_rows_1xn invertible_Hermite_of_list_of_rows_mx1 by blast
  next
    case False
    then show ?thesis 
      using invertible_Hermite_of_list_of_rows_cancelled_both[OF _ _ A eA] False mn by auto
  qed  
qed
end
end
end
end


text ‹Now we have all the required stuff to prove the soundness of the algorithm.›

context proper_mod_operation
begin

(*
thm invertible_Hermite_of_list_of_rows
thm Hermite_Hermite_of_list_of_rows
thm LLL_with_assms.Hermite_append_det_id
thm FindPreHNF_invertible_mat
thm FindPreHNF_echelon_form
*)

lemma Hermite_mod_det_mx0:
  assumes "A  carrier_mat m 0"
  shows "Hermite_mod_det abs_flag A = A"
  unfolding Hermite_mod_det_def Let_def using assms by auto

lemma Hermite_JNF_mx0:
  assumes A: "A  carrier_mat m 0"
  shows "Hermite_JNF (range ass_function_euclidean) (λc. range (res_int c)) A"
  unfolding Hermite_JNF_def using A echelon_form_mx0 unfolding is_zero_row_JNF_def 
  using ass_function_Complete_set_non_associates[OF ass_function_euclidean]
  using res_function_Complete_set_residues[OF res_function_res_int] by auto
  

lemma Hermite_mod_det_soundness_mx0:
  assumes  A: "A  carrier_mat m n"
  and n0: "n=0"
shows "Hermite_JNF (range ass_function_euclidean) (λc. range (res_int c)) (Hermite_mod_det abs_flag A)" 
and "(P. invertible_mat P  P  carrier_mat m m  (Hermite_mod_det abs_flag A) = P * A)"
proof -
  have A: "A  carrier_mat m 0" using A n0 by blast
  then show "Hermite_JNF (range ass_function_euclidean) (λc. range (res_int c)) (Hermite_mod_det abs_flag A)"
    using Hermite_JNF_mx0[OF A] Hermite_mod_det_mx0[OF A] by auto
  show "(P. invertible_mat P  P  carrier_mat m m  (Hermite_mod_det abs_flag A) = P * A)"
    by (metis A Hermite_mod_det_mx0 invertible_mat_one left_mult_one_mat one_carrier_mat)
qed


lemma Hermite_mod_det_soundness_mxn:
  assumes mn: "m = n"
  and A: "A  carrier_mat m n"
  and n0: "0<n"
  and inv_RAT_A: "invertible_mat (map_mat rat_of_int A)"
shows "Hermite_JNF (range ass_function_euclidean) (λc. range (res_int c)) (Hermite_mod_det abs_flag A)" 
  and "(P. invertible_mat P  P  carrier_mat m m  (Hermite_mod_det abs_flag A) = P * A)"
proof -
  define D A' E H H' where D_def: "D = ¦Determinant.det A¦"
  and A'_def: "A' = A @r D m 1m n" and E_def: "E = FindPreHNF abs_flag D A'"
  and H_def: "H = Hermite_of_list_of_rows E [0..<m+n]"
  and H'_def: "H' = mat_of_rows n (map (Matrix.row H) [0..<m])"
  have A': "A'  carrier_mat (m+n) n" using A A A'_def by auto
  let ?RAT = "of_int_hom.mat_hom :: int mat  rat mat"
  have RAT_A: "?RAT A  carrier_mat n n"
    using A map_carrier_mat mat_of_rows_carrier(1) mn by auto 
  have det_RAT_fs_init: "det (?RAT A)  0"
    using inv_RAT_A unfolding invertible_iff_is_unit_JNF[OF RAT_A] by auto
  moreover have "mat_of_rows n (map (Matrix.row A') [0..<n]) = A"
  proof
    let ?A' = "mat_of_rows n (map (Matrix.row A') [0..<n])"    
    show dr: "dim_row ?A' = dim_row A" and dc: "dim_col ?A' = dim_col A" using A mn by auto
    fix i j assume i: "i < dim_row A" and j: "j < dim_col A"
    have D: "D m 1m n  carrier_mat n n" using mn by auto
    have "?A' $$ (i,j) =  (map (Matrix.row A') [0..<n]) ! i $v j"
      by (rule mat_of_rows_index, insert i j dr dc A, auto) 
    also have "... = A' $$ (i,j)" using A' mn i j A by auto
    also have "... = A $$ (i,j)" unfolding A'_def using i append_rows_nth[OF A D] mn j A by auto
    finally show "?A' $$ (i, j) = A $$ (i, j)" .
  qed
  ultimately have inv_RAT_A'n: 
    "invertible_mat (map_mat rat_of_int (mat_of_rows n (map (Matrix.row A') [0..<n])))" 
    using inv_RAT_A by auto
  have eE: "echelon_form_JNF E"
    by (unfold E_def, rule FindPreHNF_echelon_form[OF A'_def A _ _],
        insert mn D_def det_RAT_fs_init, auto)
  have E: "E  carrier_mat (m+n) n" unfolding E_def by (rule FindPreHNF[OF A'])
  have "P. P  carrier_mat (m + n) (m + n)  invertible_mat P  E = P * A'"
  by (unfold E_def, rule FindPreHNF_invertible_mat[OF A'_def A n0 _ _],
      insert mn D_def det_RAT_fs_init, auto)
  from this obtain P where P: "P  carrier_mat (m + n) (m + n)"
    and inv_P: "invertible_mat P" and E_PA': "E = P * A'"
    by blast
  have "Q. Q  carrier_mat (m+n) (m+n)  invertible_mat Q  H = Q * E"
    by (unfold H_def, rule invertible_Hermite_of_list_of_rows[OF E eE])  
  from this obtain Q where Q: "Q  carrier_mat (m+n) (m+n)"
    and inv_Q: "invertible_mat Q" and H_QE: "H = Q * E" by blast
  let ?ass ="(range ass_function_euclidean)"
  let ?res = "(λc. range (res_int c))"
  have Hermite_H: "Hermite_JNF (range ass_function_euclidean) (λc. range (res_int c)) H"
    by (unfold H_def, rule Hermite_Hermite_of_list_of_rows[OF E eE])
  hence eH: "echelon_form_JNF H" unfolding Hermite_JNF_def by auto
  have H': "H'  carrier_mat m n" using H'_def by auto
  have H_H'0: "H = H' @r 0m m n"
  proof (unfold H'_def, rule upper_triangular_append_zero)
    show "upper_triangular' H" using eH by (rule echelon_form_JNF_imp_upper_triangular)
    show "H  carrier_mat (m + m) n"
      unfolding H_def using Hermite_of_list_of_rows[of E] E mn by auto
  qed (insert mn, simp)
  obtain P' where PP': "inverts_mat P P'"
    and P'P: "inverts_mat P' P" and P': "P'  carrier_mat (m+n) (m+n)"         
    using P inv_P obtain_inverse_matrix by blast
  obtain Q' where QQ': "inverts_mat Q Q'"
    and Q'Q: "inverts_mat Q' Q" and Q': "Q'  carrier_mat (m+n) (m+n)"         
    using Q inv_Q obtain_inverse_matrix by blast
  have P'Q': "(P'*Q')  carrier_mat (m + m) (m + m)" using P' Q' mn by simp
  have A'_P'Q'H: "A' = P' * Q' * H"
  proof -
    have QP: "Q * P  carrier_mat (m + m) (m + m)" using Q P mn by auto
    have "H = Q * (P * A')" using H_QE E_PA' by auto
    also have "... = (Q * P) * A'" using A' P Q by auto
    also have "(P' * Q') * ... = ((P' * Q') * (Q * P)) * A'" using A' P'Q' QP mn by auto
    also have "... =  (P' * (Q' * Q) * P) * A'"
      by (smt P P' P'Q' Q Q' assms(1) assoc_mult_mat)
    also have "... = (P'*P) * A'" 
      by (metis P' Q' Q'Q carrier_matD(1) inverts_mat_def right_mult_one_mat)
    also have "... = A'"
      by (metis A' P' P'P carrier_matD(1) inverts_mat_def left_mult_one_mat)
    finally show "A' = P' * Q' * H" ..
  qed
  have inv_P'Q': "invertible_mat (P' * Q')"
    by (metis P' P'P PP' Q' Q'Q QQ' carrier_matD(1) carrier_matD(2) invertible_mat_def
        invertible_mult_JNF square_mat.simps)
  interpret vec_module "TYPE(int)" .
  interpret B: cof_vec_space n "TYPE(rat)" .
  interpret A: LLL_with_assms n m "(Matrix.rows A)" "4/3"
  proof       
    show "length (rows A) = m " using A unfolding Matrix.rows_def by simp
    have s: "set (map of_int_hom.vec_hom (rows A))  carrier_vec n"
      using A unfolding Matrix.rows_def by auto
    have rw: "(map of_int_hom.vec_hom (rows A)) = (rows (?RAT A))" 
      by (metis A s carrier_matD(2) mat_of_rows_map mat_of_rows_rows rows_mat_of_rows set_rows_carrier subsetI)
    have "B.lin_indpt (set (map of_int_hom.vec_hom (rows A)))"
      unfolding rw by (rule B.det_not_0_imp_lin_indpt_rows[OF RAT_A det_RAT_fs_init])
    moreover have "distinct (map of_int_hom.vec_hom (rows A)::rat Matrix.vec list)"
    proof (rule ccontr)
      assume " ¬ distinct (map of_int_hom.vec_hom (rows A)::rat Matrix.vec list)"
      from this obtain i j where "row (?RAT A) i = row (?RAT A) j" and "i  j" and "i < n" and "j < n"
        unfolding rw
        by (metis Determinant.det_transpose RAT_A add_0 cols_transpose det_RAT_fs_init 
            not_add_less2 transpose_carrier_mat vec_space.det_rank_iff vec_space.non_distinct_low_rank)
      thus False using Determinant.det_identical_rows[OF RAT_A] using det_RAT_fs_init RAT_A by auto      
    qed      
    ultimately show "B.lin_indpt_list (map of_int_hom.vec_hom (rows A))"
      using s unfolding B.lin_indpt_list_def by auto
  qed (simp)
  have A_eq: "mat_of_rows n (Matrix.rows A) = A" using A mat_of_rows_rows by blast
  have D_A: "D = ¦det (mat_of_rows n (rows A))¦" using D_def A_eq by auto
  have Hermite_H': "Hermite_JNF ?ass ?res H'"
    by (rule A.Hermite_append_det_id(1)[OF _ mn _ H' H_H'0 P'Q' inv_P'Q' A'_P'Q'H Hermite_H],
         insert D_def A'_def mn A inv_RAT_A D_A A_eq, auto) 
  have dc: "dim_row A = m" and dr: "dim_col A = n" using A by auto
  have Hermite_mod_det_H': "Hermite_mod_det abs_flag A = H'" 
    unfolding Hermite_mod_det_def Let_def H'_def H_def E_def A'_def D_def dc dr det_int by blast
  show "Hermite_JNF ?ass ?res (Hermite_mod_det abs_flag A)" using Hermite_mod_det_H' Hermite_H' by simp
  have "R. invertible_mat R  R  carrier_mat m m  A = R * H'"
    by (subst A_eq[symmetric], 
        rule A.Hermite_append_det_id(2)[OF _ mn _ H' H_H'0 P'Q' inv_P'Q' A'_P'Q'H Hermite_H],
        insert D_def A'_def mn A inv_RAT_A D_A A_eq, auto)
  from this obtain R where inv_R: "invertible_mat R" 
    and R: "R  carrier_mat m m" and A_RH': "A = R * H'"
    by blast
  obtain R' where inverts_R: "inverts_mat R R'" and R': "R'  carrier_mat m m"    
    by (meson R inv_R obtain_inverse_matrix)
  have inv_R': "invertible_mat R'" using inverts_R unfolding invertible_mat_def inverts_mat_def
    using R R' mat_mult_left_right_inverse by auto
  moreover have "H' = R' * A"
  proof -
    have "R' * A = R' * (R * H')" using A_RH' by auto
    also have "... = (R'*R) * H'" using H' R R' by auto
    also have "... = H'"
      by (metis H' R R' mat_mult_left_right_inverse carrier_matD(1) 
          inverts_R inverts_mat_def left_mult_one_mat)
    finally show ?thesis ..
  qed
  ultimately show "S. invertible_mat S  S  carrier_mat m m  Hermite_mod_det abs_flag A = S * A" 
    using R' Hermite_mod_det_H' by blast
qed


lemma Hermite_mod_det_soundness:
  assumes mn: "m = n"
  and A_def: "A  carrier_mat m n"
  and i: "invertible_mat (map_mat rat_of_int A)"
shows "Hermite_JNF (range ass_function_euclidean) (λc. range (res_int c)) (Hermite_mod_det abs_flag A)" 
  and "(P. invertible_mat P  P  carrier_mat m m  (Hermite_mod_det abs_flag A) = P * A)" 
  using A_def Hermite_mod_det_soundness_mx0(1) Hermite_mod_det_soundness_mxn(1) mn i 
  by blast (insert Hermite_mod_det_soundness_mx0(2) Hermite_mod_det_soundness_mxn(2) assms, blast)


text ‹We can even move the whole echelon form algorithm @{text "echelon_form_of"} from HOL Analysis 
to JNF and then we can combine it with @{text "Hermite_of_list_of_rows"} to have another 
HNF algorithm which is not efficient, but valid for arbitrary matrices.›

lemma reduce_D0:
"reduce a b 0 A = (let Aaj = A$$(a,0); Abj = A $$ (b,0)     
  in
  if Aaj = 0 then A else
  case euclid_ext2 Aaj Abj of (p,q,u,v,d)  
       Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a then  (p*A$$(a,k) + q*A$$(b,k))
                   else if i = b then  u * A$$(a,k) + v * A$$(b,k)
                   else A$$(i,k)
            )
  )" (is "?lhs = ?rhs")
proof 
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A $$ (a, 0)) (A $$ (b, 0))"
    by (simp add: euclid_ext2_def) 
  have *:" Matrix.mat (dim_row A) (dim_col A)
        (λ(i, k).
            if i = a then let r = p * A $$ (a, k) + q * A $$ (b, k) in if 0 < ¦r¦ then 
                                  if k = 0  0 dvd r then 0 else r mod 0 else r
            else if i = b then let r = u * A $$ (a, k) + v * A $$ (b, k) in 
                              if 0 < ¦r¦ then r mod 0 else r else A $$ (i, k)) 
        = Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a then  (p*A$$(a,k) + q*A$$(b,k))
                   else if i = b then  u * A$$(a,k) + v * A$$(b,k)
                   else A$$(i,k) 
            )" 
    by (rule eq_matI, auto simp add: Let_def)
  show "dim_row ?lhs = dim_row ?rhs" 
    unfolding reduce.simps Let_def by (smt dim_row_mat(1) pquvd prod.simps(2))
  show "dim_col ?lhs = dim_col ?rhs"
    unfolding reduce.simps Let_def by (smt dim_col_mat(1) pquvd prod.simps(2))
  fix i j assume i: "i<dim_row ?rhs" and j: "j<dim_col ?rhs"
  show "?lhs $$ (i,j) = ?rhs $$ (i,j)"
    by (cases " A $$ (a, 0) = 0", insert * pquvd i j, auto simp add: case_prod_beta Let_def)
qed



lemma bezout_matrix_JNF_mult_eq':
  assumes A': "A'  carrier_mat m n" and a: "a<m"  and b: "b<m" and ab: "a  b" 
  and A_def: "A = A' @r B" and B: "B  carrier_mat t n"
  assumes pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,j)) (A$$(b,j))"
  shows "Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a then (p*A$$(a,k) + q*A$$(b,k))
                   else if i = b then u * A$$(a,k) + v * A$$(b,k)
                   else A$$(i,k)
            ) = (bezout_matrix_JNF A a b j euclid_ext2) * A" (is "?A = ?BM * A")
proof (rule eq_matI) 
  have A: "A  carrier_mat (m+t) n" using A_def A' B by simp
  hence A_carrier: "?A  carrier_mat (m+t) n" by auto  
  show dr: "dim_row ?A = dim_row (?BM * A)" and dc: "dim_col ?A = dim_col (?BM * A)"
    unfolding bezout_matrix_JNF_def by auto
  fix i ja assume i: "i < dim_row  (?BM * A)" and ja: "ja < dim_col (?BM * A)"
  let ?f = "λia. (bezout_matrix_JNF A a b j euclid_ext2) $$ (i,ia) * A $$ (ia,ja)"
  have dv: "dim_vec (col A ja) = m+t" using A by auto
  have i_dr: "i<dim_row A" using i A unfolding bezout_matrix_JNF_def by auto
  have a_dr: "a<dim_row A" using A a ja by auto
  have b_dr: "b<dim_row A" using A b ja by auto
  show "?A $$ (i,ja) = (?BM * A) $$ (i,ja)"
  proof -
    have "(?BM * A) $$ (i,ja) = Matrix.row ?BM i  col A ja"
      by (rule index_mult_mat, insert i ja, auto)
    also have "... = (ia = 0..<dim_vec (col A ja). 
          Matrix.row (bezout_matrix_JNF A a b j euclid_ext2) i $v ia * col A ja $v ia)"
      by (simp add: scalar_prod_def)
    also have "... = (ia = 0..<m+t. ?f ia)"
      by (rule sum.cong, insert A i dr dc, auto) (smt bezout_matrix_JNF_def carrier_matD(1) 
          dim_col_mat(1) index_col index_mult_mat(3) index_row(1) ja)
    also have "... = (ia  ({a,b}  ({0..<m+t} - {a,b})). ?f ia)"
      by (rule sum.cong, insert a a_dr b A ja, auto)
    also have "... = sum ?f {a,b} + sum ?f ({0..<m+t} - {a,b})" 
      by (rule sum.union_disjoint, auto)
    finally have BM_A_ija_eq: "(?BM * A) $$ (i,ja) = sum ?f {a,b} + sum ?f ({0..<m+t} - {a,b})" by auto
    show ?thesis
    proof (cases "i = a")
      case True
      have sum0: "sum ?f ({0..<m+t} - {a,b}) = 0"
      proof (rule sum.neutral, rule)
        fix x assume x: "x  {0..<m + t} - {a, b}"
        hence xm: "x < m+t" by auto
        have x_not_i: "x  i" using True x by blast
        have x_dr: "x < dim_row A" using x A by auto
        have "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, x) = 0"
          unfolding bezout_matrix_JNF_def 
          unfolding index_mat(1)[OF i_dr x_dr] using x_not_i x by auto
        thus "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, x) * A $$ (x, ja) = 0" by auto
      qed
      have fa: "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, a) = p" 
        unfolding bezout_matrix_JNF_def index_mat(1)[OF i_dr a_dr] using True pquvd 
        by (auto, metis split_conv)
      have fb: "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, b) = q"
        unfolding bezout_matrix_JNF_def index_mat(1)[OF i_dr b_dr] using True pquvd ab
        by (auto, metis split_conv)
      have "sum ?f {a,b} + sum ?f ({0..<m+t} - {a,b}) = ?f a + ?f b" using sum0 by (simp add: ab)
      also have "... = p * A $$ (a, ja) + q * A $$ (b, ja)" unfolding fa fb by simp
      also have "... = ?A $$ (i,ja)" using A True dr i ja by auto
      finally show ?thesis using BM_A_ija_eq by simp
    next
      case False note i_not_a = False
      show ?thesis
      proof (cases "i=b")
        case True
        have sum0: "sum ?f ({0..<m+t} - {a,b}) = 0"
        proof (rule sum.neutral, rule)
          fix x assume x: "x  {0..<m + t} - {a, b}"
          hence xm: "x < m+t" by auto
          have x_not_i: "x  i" using True x by blast
          have x_dr: "x < dim_row A" using x A by auto
          have "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, x) = 0"
            unfolding bezout_matrix_JNF_def 
            unfolding index_mat(1)[OF i_dr x_dr] using x_not_i x by auto
          thus "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, x) * A $$ (x, ja) = 0" by auto
        qed
        have fa: "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, a) = u" 
          unfolding bezout_matrix_JNF_def index_mat(1)[OF i_dr a_dr] using True i_not_a pquvd 
          by (auto, metis split_conv)
        have fb: "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, b) = v"
          unfolding bezout_matrix_JNF_def index_mat(1)[OF i_dr b_dr] using True i_not_a pquvd ab
          by (auto, metis split_conv)
        have "sum ?f {a,b} + sum ?f ({0..<m+t} - {a,b}) = ?f a + ?f b" using sum0 by (simp add: ab)
        also have "... = u * A $$ (a, ja) + v * A $$ (b, ja)" unfolding fa fb by simp
        also have "... = ?A $$ (i,ja)" using A True i_not_a dr i ja by auto
        finally show ?thesis using BM_A_ija_eq by simp
      next
        case False note i_not_b = False
        have sum0: "sum ?f ({0..<m+t} - {a,b} - {i}) = 0" 
        proof (rule sum.neutral, rule)
          fix x assume x: "x  {0..<m + t} - {a, b} - {i}"
          hence xm: "x < m+t" by auto
          have x_not_i: "x  i" using x by blast
          have x_dr: "x < dim_row A" using x A by auto
          have "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, x) = 0"
            unfolding bezout_matrix_JNF_def 
            unfolding index_mat(1)[OF i_dr x_dr] using x_not_i x by auto
          thus "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, x) * A $$ (x, ja) = 0" by auto
        qed
        have fa: "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, a) = 0" 
          unfolding bezout_matrix_JNF_def index_mat(1)[OF i_dr a_dr] using False i_not_a pquvd 
          by auto
        have fb: "bezout_matrix_JNF A a b j euclid_ext2 $$ (i, b) = 0" 
          unfolding bezout_matrix_JNF_def index_mat(1)[OF i_dr b_dr] using False i_not_a pquvd 
          by auto
        have "sum ?f ({0..<m+t} - {a,b}) = sum ?f (insert i ({0..<m+t} - {a,b} - {i}))"
          by (rule sum.cong, insert i_dr A i_not_a i_not_b, auto)
        also have "... = ?f i + sum ?f ({0..<m+t} - {a,b} - {i})" by (rule sum.insert, auto)
        also have "... = ?f i" using sum0 by simp
        also have "... = ?A $$ (i,ja)"
          unfolding bezout_matrix_JNF_def using i_not_a i_not_b  A dr i ja by fastforce
        finally show ?thesis unfolding BM_A_ija_eq by (simp add: ab fa fb)
      qed    
    qed
  qed
qed



lemma bezout_matrix_JNF_mult_eq2:
  assumes A: "A  carrier_mat m n" and a: "a<m"  and b: "b<m" and ab: "a  b" 
  assumes pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,j)) (A$$(b,j))"
  shows "Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a then (p*A$$(a,k) + q*A$$(b,k))
                   else if i = b then u * A$$(a,k) + v * A$$(b,k)
                   else A$$(i,k)
            ) = (bezout_matrix_JNF A a b j euclid_ext2) * A" (is "?A = ?BM * A")
proof (rule bezout_matrix_JNF_mult_eq'[OF A a b ab _ _ pquvd])
  show "A = A @r (0m 0 n)" by (rule eq_matI, unfold append_rows_def, auto)
  show "(0m 0 n)  carrier_mat 0 n" by auto
qed


lemma reduce_invertible_mat_D0_BM:
  assumes A: "A  carrier_mat m n"
  and a: "a < m"
  and b: "b < m"
  and ab: "a  b"
  and Aa0: "A$$(a,0)  0"
  shows "reduce a b 0 A = (bezout_matrix_JNF A a b 0 euclid_ext2) * A"
proof -
 obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(b,0))"
    by (simp add: euclid_ext2_def)
  let ?BM = "bezout_matrix_JNF A a b 0 euclid_ext2"
  let ?A = "Matrix.mat (dim_row A) (dim_col A)
          (λ(i,k). if i = a then  (p*A$$(a,k) + q*A$$(b,k))
                   else if i = b then  u * A$$(a,k) + v * A$$(b,k)
                   else A$$(i,k))"
  have A'_BZ_A: "?A = ?BM * A"
    by (rule bezout_matrix_JNF_mult_eq2[OF A _ _ ab pquvd], insert a b, auto)  
  moreover have "?A = reduce a b 0 A" using pquvd Aa0 unfolding reduce_D0 Let_def
    by (metis (no_types, lifting) split_conv)
  ultimately show ?thesis by simp
qed


lemma reduce_invertible_mat_D0:
  assumes A: "A  carrier_mat m n"
  and a: "a < m"
  and b: "b < m"
  and n0: "0<n"
  and ab: "a  b"
  and a_less_b: "a<b"
  shows "P. invertible_mat P  P  carrier_mat m m  reduce a b 0 A = P * A"
proof (cases "A$$(a,0) = 0")
  case True
  then show ?thesis
    by (smt A invertible_mat_one left_mult_one_mat one_carrier_mat reduce.simps)
next
  case False
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(b,0))"
    by (simp add: euclid_ext2_def)
  let ?BM = "bezout_matrix_JNF A a b 0 euclid_ext2"
  have "reduce a b 0 A = ?BM * A"  by (rule reduce_invertible_mat_D0_BM[OF A a b ab False])
  moreover have invertible_bezout: "invertible_mat ?BM"
    by (rule invertible_bezout_matrix_JNF[OF A is_bezout_ext_euclid_ext2 a_less_b _ n0 False],
        insert a_less_b b, auto)      
  moreover have BM: "?BM  carrier_mat m m" unfolding bezout_matrix_JNF_def using A by auto
  ultimately show ?thesis by blast
qed

lemma reduce_below_invertible_mat_D0:
  assumes A': "A  carrier_mat m n" and a: "a<m" and j: "0<n"
    and "distinct xs" and "x  set xs. x < m  a < x"
  and "D=0"
shows "(P. invertible_mat P  P  carrier_mat m m  reduce_below a xs D A = P * A)"
  using assms
proof (induct a xs D A arbitrary: A rule: reduce_below.induct)
  case (1 a D A)
  then show ?case
    by (auto, metis invertible_mat_one left_mult_one_mat one_carrier_mat)
next
  case (2 a x xs D A)
  note A = "2.prems"(1)
  note a = "2.prems"(2)
  note j = "2.prems"(3)
  note d = "2.prems"(4)
  note x_xs = "2.prems"(5)
  note D0 = "2.prems"(6)
  have xm: "x < m" using "2.prems" by auto
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "reduce a x D A"
  have reduce_ax: "?reduce_ax  carrier_mat m n"
    by (metis (no_types, lifting) "2" add.comm_neutral append_rows_def 
        carrier_matD carrier_mat_triv index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3) reduce_preserves_dimensions)
  have h: "(P. invertible_mat P  P  carrier_mat m m
     reduce_below a xs D (reduce a x D A) = P * reduce a x D A)"
    by (rule "2.hyps"[OF _ a j _ _ ],insert  d x_xs  D0 reduce_ax, auto)   
  from this obtain P where inv_P: "invertible_mat P" and P: "P  carrier_mat m m"
    and rb_Pr: "reduce_below a xs D (reduce a x D A) = P * reduce a x D A" by blast
  have *: "reduce_below a (x # xs) D A = reduce_below a xs D (reduce a x D A)" by simp
  have "Q. invertible_mat Q  Q  carrier_mat m m  (reduce a x D A) = Q * A"
    by (unfold D0, rule reduce_invertible_mat_D0[OF A a xm j], insert "2.prems", auto)
  from this obtain Q where inv_Q: "invertible_mat Q" and Q: "Q  carrier_mat m m"
    and r_QA: "reduce a x D A = Q * A" by blast
  have "invertible_mat (P*Q)" using inv_P inv_Q P Q invertible_mult_JNF by blast
  moreover have "P * Q  carrier_mat m m" using P Q by auto
  moreover have "reduce_below a (x # xs) D A = (P*Q) * A" 
    by (smt P Q * assoc_mult_mat carrier_matD(1) carrier_mat_triv index_mult_mat(2) 
        r_QA rb_Pr reduce_preserves_dimensions(1))
  ultimately show ?case by blast
qed


(*This lemma permits to get rid of one assumption in reduce_not0*)
lemma reduce_not0':
  assumes A: "A  carrier_mat m n" and a: "a<m" and a_less_b: "a<b" and j: "0<n" and b: "b<m"
    and Aaj: "A $$ (a,0)  0"
  shows "reduce a b 0 A $$ (a, 0)  0" (is "?reduce_ab $$ (a,0)  _")
proof -
  have "?reduce_ab $$ (a,0) = (let r = gcd (A $$ (a, 0)) (A $$ (b, 0)) in if 0 dvd r then 0 else r)" 
    by (rule reduce_gcd[OF A _ j Aaj], insert a, simp)
  also have "...  0" unfolding Let_def
    by (simp add: assms(6))
  finally show ?thesis .
qed


lemma reduce_below_preserves_D0:
  assumes A': "A  carrier_mat m n" and a: "a<m" and j: "j<n"
    and Aaj: "A $$ (a,0)  0"
  assumes "i  set xs" and "distinct xs" and "x  set xs. x < m  a < x"
    and "ia" and "i<m"
  and "D=0"
  shows "reduce_below a xs D A $$ (i,j) = A $$ (i,j)"
  using assms
proof (induct a xs D A arbitrary: A i rule: reduce_below.induct)
  case (1 a D A)
  then show ?case by auto
next
  case (2 a x xs D A)
  note A = "2.prems"(1)
  note a = "2.prems"(2)
  note j = "2.prems"(3)
  note Aaj = "2.prems"(4)
  note i_set_xxs = "2.prems"(5)
  note d = "2.prems"(6)
  note xxs_less_m = "2.prems"(7)
  note ia = "2.prems"(8)
  note im = "2.prems"(9)
  note D0 = "2.prems"(10)
  have xm: "x < m"  using "2.prems" by auto
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "(reduce a x D A)"
  have reduce_ax: "?reduce_ax  carrier_mat m n"
    by (metis (no_types, lifting) "2" add.comm_neutral append_rows_def 
        carrier_matD carrier_mat_triv index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3) reduce_preserves_dimensions)
  have "reduce_below a (x # xs) D A $$ (i, j) = reduce_below a xs D (reduce a x D A) $$ (i, j)"
    by auto
  also have "... = reduce a x D A $$ (i, j)"
  proof (rule "2.hyps"[OF _ a j _ _ ])   
    show "i  set xs" using i_set_xxs by auto
    show "distinct xs" using d by auto
    show "xset xs. x < m  a < x" using xxs_less_m by auto
    show "reduce a x D A $$ (a, 0)  0"
      by (unfold D0, rule reduce_not0'[OF A _ _ _ _ Aaj], insert "2.prems", auto)
    show "reduce a x D A  carrier_mat m n" using reduce_ax by linarith
  qed (insert "2.prems", auto)
  also have "... = A $$ (i,j)" by (rule reduce_preserves[OF A j Aaj], insert "2.prems", auto)
  finally show ?case .
qed



lemma reduce_below_0_D0:
  assumes A: "A  carrier_mat m n" and a: "a<m" and j: "0<n"
    and Aaj: "A $$ (a,0)  0"
  assumes "i  set xs" and "distinct xs" and "x  set xs. x < m  a < x"
  and "D=0"
  shows "reduce_below a xs D A $$ (i,0) = 0"
  using assms
proof (induct a xs D A arbitrary: A i rule: reduce_below.induct)
  case (1 a D A)
  then show ?case by auto 
next
  case (2 a x xs D A)
  note A = "2.prems"(1)
  note a = "2.prems"(2)
  note j = "2.prems"(3)
  note Aaj = "2.prems"(4)
  note i_set_xxs = "2.prems"(5)
  note d = "2.prems"(6)
  note xxs_less_m = "2.prems"(7)
  note D0 = "2.prems"(8)
  have xm: "x < m"  using "2.prems" by auto
  obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 (A$$(a,0)) (A$$(x,0))"
    by (metis prod_cases5)
  let ?reduce_ax = "reduce a x D A"
  have reduce_ax: "?reduce_ax  carrier_mat m n"
    by (metis (no_types, lifting) "2" add.comm_neutral append_rows_def 
        carrier_matD carrier_mat_triv index_mat_four_block(2,3)
        index_one_mat(2) index_smult_mat(2) index_zero_mat(2,3) reduce_preserves_dimensions)
  show ?case
  proof (cases "i=x")
    case True
    have "reduce_below a (x # xs) D A $$ (i, 0) = reduce_below a xs D (reduce a x D A) $$ (i, 0)"
      by auto
    also have "... = (reduce a x D A) $$ (i, 0)"
    proof (rule reduce_below_preserves_D0[OF _ a j _ _ ])
      show "reduce a x D A  carrier_mat m n" using reduce_ax by linarith
      show "distinct xs" using d by auto
      show "xset xs. x < m  a < x" using xxs_less_m by auto
      show "reduce a x D A $$ (a, 0)  0"
        by (unfold D0, rule reduce_not0'[OF A _ _ j _ Aaj], insert "2.prems", auto)
      show "i  set xs" using True d by auto
      show "i  a" using "2.prems" by blast
      show "i < m" by (simp add: True trans_less_add1 xm)
    qed (insert D0)
    also have "... = 0" unfolding True by (rule reduce_0[OF A _ j _ _ Aaj], insert "2.prems", auto)
    finally show ?thesis .
  next
    case False note i_not_x = False    
    have h: "reduce_below a xs D (reduce a x D A) $$ (i, 0) = 0 "
    proof (rule "2.hyps"[OF _ a j _ _ ])
      show "reduce a x D A  carrier_mat m n" using reduce_ax by linarith
      show "i  set xs" using i_set_xxs i_not_x by auto
      show "distinct xs" using d by auto
      show "xset xs. x < m  a < x" using xxs_less_m by auto
      show "reduce a x D A $$ (a, 0)  0"
        by (unfold D0, rule reduce_not0'[OF A _ _ j _ Aaj], insert "2.prems", auto)
    qed (insert D0)
    have "reduce_below a (x # xs) D A $$ (i, 0) = reduce_below a xs D (reduce a x D A) $$ (i, 0)"
      by auto
    also have "... = 0" using h .
    finally show ?thesis .
  qed
qed

end

text ‹Definition of the echelon form algorithm in JNF›

primrec bezout_iterate_JNF
where "bezout_iterate_JNF A 0 i j bezout = A"
    | "bezout_iterate_JNF A (Suc n) i j bezout = 
        (if (Suc n)  i then A else 
              bezout_iterate_JNF (bezout_matrix_JNF A i ((Suc n)) j bezout * A) n i j bezout)"

definition 
  "echelon_form_of_column_k_JNF bezout A' k = 
    (let (A, i) = A' 
     in if (i = dim_row A)  (m  {i..<dim_row A}. A $$ (m, k) = 0) then (A, i) else 
        if (m{i+1..<dim_row A}. A $$ (m,k) = 0) then (A, i + 1) else
            let n = (LEAST n. A $$ (n,k)  0  i  n); 
                interchange_A = swaprows i n A
           in
            (bezout_iterate_JNF (interchange_A) (dim_row A - 1) i k bezout, i + 1) )"


definition "echelon_form_of_upt_k_JNF A k bezout = (fst (foldl (echelon_form_of_column_k_JNF bezout) (A,0) [0..<Suc k]))"
definition "echelon_form_of_JNF A bezout = echelon_form_of_upt_k_JNF A (dim_col A - 1) bezout"


context includes lifting_syntax
begin

lemma HMA_bezout_iterate[transfer_rule]: 
  assumes "n<CARD('m)"
  shows "((Mod_Type_Connect.HMA_M :: _  int ^ 'n :: mod_type ^ 'm :: mod_type  _) 
     ===> (Mod_Type_Connect.HMA_I) ===> (Mod_Type_Connect.HMA_I) ===> (=) ===> (Mod_Type_Connect.HMA_M)) 
  (λA i j bezout. bezout_iterate_JNF A n i j bezout)  
  (λA i j bezout. bezout_iterate A n i j bezout)
  "
proof (intro rel_funI, goal_cases)
  case (1 A A' i i' j j' bezout bezout')
  then show ?case using assms
  proof (induct n arbitrary: A A')
    case 0
    then show ?case by auto
  next
    case (Suc n)
    note AA'[transfer_rule] = "Suc.prems"(1)
    note ii'[transfer_rule] = "Suc.prems"(2)
    note jj'[transfer_rule] = "Suc.prems"(3)
    note bb'[transfer_rule] = "Suc.prems"(4)
    note Suc_n_less_m = "Suc.prems"(5)
    let ?BI_JNF = "bezout_iterate_JNF"
    let ?BI_HMA = "bezout_iterate"
    let ?from_nat_rows = "mod_type_class.from_nat :: _  'm"
    have Sucn[transfer_rule]: "Mod_Type_Connect.HMA_I (Suc n) (?from_nat_rows (Suc n))"
      unfolding Mod_Type_Connect.HMA_I_def
      by (simp add: Suc_lessD Suc_n_less_m mod_type_class.from_nat_to_nat)
    have n: " n < CARD('m)" using Suc_n_less_m by simp
    have [transfer_rule]: 
      "Mod_Type_Connect.HMA_M (?BI_JNF (bezout_matrix_JNF A i (Suc n) j bezout * A) n i j bezout)
     (?BI_HMA (bezout_matrix A' i' (?from_nat_rows (Suc n)) j' bezout' ** A') n i' j' bezout')"    
      by (rule Suc.hyps[OF _ ii' jj' bb' n], transfer_prover)
    moreover have "Suc n  i   Suc n  mod_type_class.to_nat i'"
      and "Suc n > i  Suc n > mod_type_class.to_nat i'" 
      by (metis "1"(2) Mod_Type_Connect.HMA_I_def)+
    ultimately show ?case using AA' by auto
  qed
qed


corollary HMA_bezout_iterate'[transfer_rule]: 
  fixes A'::"int ^ 'n :: mod_type ^ 'm :: mod_type"
  assumes n: "n<CARD('m)"
  and "Mod_Type_Connect.HMA_M A A'"
   and "Mod_Type_Connect.HMA_I i i'" and "Mod_Type_Connect.HMA_I j j'" 
 shows "Mod_Type_Connect.HMA_M (bezout_iterate_JNF A n i j bezout) (bezout_iterate A' n i' j' bezout)"
  using assms HMA_bezout_iterate[OF n] unfolding rel_fun_def by force



lemma snd_echelon_form_of_column_k_JNF_le_dim_row:
  assumes "i<dim_row A"
  shows "snd (echelon_form_of_column_k_JNF bezout (A,i) k )  dim_row A"   
  using assms unfolding echelon_form_of_column_k_JNF_def by auto



lemma HMA_echelon_form_of_column_k[transfer_rule]: 
  assumes k: "k<CARD('n)"
  shows "((=) ===> rel_prod (Mod_Type_Connect.HMA_M :: _  int ^ 'n :: mod_type ^ 'm :: mod_type  _) (λa b. a=b  aCARD('m))
    ===> (rel_prod (Mod_Type_Connect.HMA_M) (λa b. a=b  aCARD('m)))) 
  (λbezout A. echelon_form_of_column_k_JNF bezout A k)  
  (λbezout A. echelon_form_of_column_k bezout A k)
  "
proof (intro rel_funI, goal_cases)
  case (1 bezout bezout' xa ya )
  obtain A i where xa: "xa = (A,i)" using surjective_pairing by blast
  obtain A' i' where ya: "ya = (A',i')" using surjective_pairing by blast
  have ii'[transfer_rule]: "i=i'" using "1"(2) xa ya by auto
  have i_le_m: "iCARD('m)"  using "1"(2) xa ya by auto
  have AA'[transfer_rule]: "Mod_Type_Connect.HMA_M A A'" using "1"(2) xa ya by auto
  have bb'[transfer_rule]: "bezout=bezout'" using "1" by auto
  let ?from_nat_rows = "mod_type_class.from_nat :: _  'm"
  let ?from_nat_cols = "mod_type_class.from_nat :: _  'n"
  have kk'[transfer_rule]: "Mod_Type_Connect.HMA_I k (?from_nat_cols k)"
    by (simp add: Mod_Type_Connect.HMA_I_def assms mod_type_class.to_nat_from_nat_id)
  have c1_eq: "(i = dim_row A) = (i = nrows A')"
    by (metis AA' Mod_Type_Connect.dim_row_transfer_rule nrows_def)
  have c2_eq: "(m  {i..<dim_row A}. A $$ (m, k) = 0) 
      = (m?from_nat_rows i. A' $ m $ ?from_nat_cols k = 0)" (is "?lhs = ?rhs") if i_not: "idim_row A" 
  proof 
    assume lhs: "?lhs"
    show "?rhs"
    proof (rule+)    
      fix m 
      assume im: "?from_nat_rows i  m"
      have im': "i<CARD('m)" using i_le_m i_not
        by (simp add: c1_eq dual_order.order_iff_strict nrows_def)
      let ?m' = "mod_type_class.to_nat m"
      have mm'[transfer_rule]: "Mod_Type_Connect.HMA_I ?m' m" 
        by (simp add: Mod_Type_Connect.HMA_I_def)
      from im have "mod_type_class.to_nat (?from_nat_rows i)  ?m'"
        by (simp add: to_nat_mono')
      hence "?m' >= i" using im im' by (simp add: mod_type_class.to_nat_from_nat_id)
      hence "?m'  {i..<dim_row A}"
        using AA' Mod_Type_Connect.dim_row_transfer_rule mod_type_class.to_nat_less_card by fastforce
      hence "A $$ (?m', k) = 0" using lhs by auto
      moreover have "A $$ (?m', k) = A' $h m $h ?from_nat_cols k" unfolding index_hma_def[symmetric] by transfer_prover
      ultimately show "A' $h m $h ?from_nat_cols k = 0" by simp
    qed
  next
    assume rhs: "?rhs"
    show "?lhs"
    proof (rule)
      fix m assume m: "m  {i..<dim_row A}"
      let ?m = "?from_nat_rows m"
      have mm'[transfer_rule]: "Mod_Type_Connect.HMA_I m ?m" 
        by (metis AA' Mod_Type_Connect.HMA_I_def Mod_Type_Connect.dim_row_transfer_rule
            atLeastLessThan_iff m mod_type_class.from_nat_to_nat)
      have m_ge_i: "?m?from_nat_rows i"
        using AA' Mod_Type_Connect.dim_row_transfer_rule from_nat_mono' m by fastforce
      hence "A' $h ?m $h ?from_nat_cols k = 0" using rhs by auto
      moreover have "A $$ (m, k) = A' $h ?m $h ?from_nat_cols k"
        unfolding index_hma_def[symmetric] by transfer_prover
      ultimately show "A $$ (m, k) = 0" by simp
    qed
  qed
  show ?case 
  proof (cases "(i = dim_row A)  (m  {i..<dim_row A}. A $$ (m, k) = 0)")
    case True   
    hence *: "(m?from_nat_rows i. A' $ m $ ?from_nat_cols k = 0)  (i = nrows A')"
      using c1_eq c2_eq by auto
    have "echelon_form_of_column_k_JNF bezout xa k = (A,i)" 
      unfolding echelon_form_of_column_k_JNF_def using True xa by auto
    moreover have "echelon_form_of_column_k bezout ya k = (A',i')"
      unfolding echelon_form_of_column_k_def Let_def using * ya ii' by simp
    ultimately show ?thesis unfolding xa ya rel_prod.simps using AA' ii' bb' i_le_m by blast    
  next
    case False note not_c1 = False
    hence im': "i<CARD('m)"
      by (metis c1_eq dual_order.order_iff_strict i_le_m nrows_def)
    have *: "(m{i+1..<dim_row A}. A $$ (m,k) = 0) 
      = (m>?from_nat_rows i. A' $ m $ ?from_nat_cols k = 0)" (is "?lhs = ?rhs")
    proof 
      assume lhs: "?lhs"
      show "?rhs"
      proof (rule+)    
        fix m 
        assume im: "?from_nat_rows i < m"     
        let ?m' = "mod_type_class.to_nat m"
        have mm'[transfer_rule]: "Mod_Type_Connect.HMA_I ?m' m" 
          by (simp add: Mod_Type_Connect.HMA_I_def)
        from im have "mod_type_class.to_nat (?from_nat_rows i) < ?m'"
          by (simp add: to_nat_mono)
        hence "?m' > i" using im im' by (simp add: mod_type_class.to_nat_from_nat_id)
        hence "?m'  {i+1..<dim_row A}"
          using AA' Mod_Type_Connect.dim_row_transfer_rule mod_type_class.to_nat_less_card by fastforce
        hence "A $$ (?m', k) = 0" using lhs by auto
        moreover have "A $$ (?m', k) = A' $h m $h ?from_nat_cols k" unfolding index_hma_def[symmetric] by transfer_prover
        ultimately show "A' $h m $h ?from_nat_cols k = 0" by simp
      qed
    next
      assume rhs: "?rhs"
      show "?lhs"
      proof (rule)
        fix m assume m: "m  {i+1..<dim_row A}"
        let ?m = "?from_nat_rows m"
        have mm'[transfer_rule]: "Mod_Type_Connect.HMA_I m ?m" 
          by (metis AA' Mod_Type_Connect.HMA_I_def Mod_Type_Connect.dim_row_transfer_rule
              atLeastLessThan_iff m mod_type_class.from_nat_to_nat)
        have m_ge_i: "?m>?from_nat_rows i"
          by (metis Mod_Type_Connect.HMA_I_def One_nat_def add_Suc_right atLeastLessThan_iff from_nat_mono
              le_simps(3) m mm' mod_type_class.to_nat_less_card nat_arith.rule0)
        hence "A' $h ?m $h ?from_nat_cols k = 0" using rhs by auto
        moreover have "A $$ (m, k) = A' $h ?m $h ?from_nat_cols k"
          unfolding index_hma_def[symmetric] by transfer_prover
        ultimately show "A $$ (m, k) = 0" by simp
      qed
    qed
    show ?thesis
    proof (cases "(m{i+1..<dim_row A}. A $$ (m,k) = 0)")
      case True
      have "echelon_form_of_column_k_JNF bezout xa k = (A,i+1)" 
        unfolding echelon_form_of_column_k_JNF_def using True xa not_c1 by auto
      moreover have "echelon_form_of_column_k bezout ya k = (A',i'+1)"
        unfolding echelon_form_of_column_k_def Let_def using ya ii' * True c1_eq c2_eq not_c1 by auto
      ultimately show ?thesis unfolding xa ya rel_prod.simps using AA' ii' bb' i_le_m
        by (metis Mod_Type_Connect.dim_row_transfer_rule le_neq_implies_less le_simps(3) not_c1 semiring_norm(175))      
    next
      case False
      hence *: "¬ (m>?from_nat_rows i. A' $ m $ ?from_nat_cols k = 0)" using * by auto
      have **: "¬ ((m?from_nat_rows i. A' $h m $h ?from_nat_cols k = 0)  i = nrows A')"
        using c1_eq c2_eq not_c1 by auto
      define n where "n=(LEAST n. A $$ (n,k)  0  i  n)"
      define n' where "n'=(LEAST n. A' $ n $ ?from_nat_cols k  0  ?from_nat_rows i  n)"
      let ?interchange_A = "swaprows i n A"
      let ?interchange_A' = "interchange_rows A' (?from_nat_rows i') n'"      
      have nn'[transfer_rule]: "Mod_Type_Connect.HMA_I n n'"
      proof -
        let ?n' = "mod_type_class.to_nat n'"
        have exist: "n. A' $ n $ ?from_nat_cols k  0  ?from_nat_rows i  n"
          using * by auto
        from this obtain a where c: "A' $ a $ ?from_nat_cols k  0  ?from_nat_rows i  a" by blast        
        have "n = ?n'"
        proof (unfold n_def, rule Least_equality)
          have n'n'[transfer_rule]: "Mod_Type_Connect.HMA_I ?n' n'"
            by (simp add: Mod_Type_Connect.HMA_I_def)
          have e: "(A' $ n' $ ?from_nat_cols k  0  ?from_nat_rows i  n')"
            by (metis (mono_tags, lifting) LeastI c2_eq n'_def not_c1) 
          hence  "i  mod_type_class.to_nat n'" 
            using im' mod_type_class.from_nat_to_nat to_nat_mono' by fastforce       
          moreover have "A' $ n' $ ?from_nat_cols k = A $$ (?n', k)" 
            unfolding index_hma_def[symmetric] by (transfer', auto)
          ultimately show "A $$ (?n', k)  0  i  ?n'"
            using e by auto
          show " y. A $$ (y, k)  0  i  y  mod_type_class.to_nat n'  y"
            by (smt AA' Mod_Type_Connect.HMA_M_def Mod_Type_Connect.from_hmam_def assms from_nat_mono
                from_nat_mono' index_mat(1) linorder_not_less mod_type_class.from_nat_to_nat_id
                mod_type_class.to_nat_less_card n'_def order.strict_trans prod.simps(2) wellorder_Least_lemma(2))
        qed
        thus ?thesis unfolding Mod_Type_Connect.HMA_I_def by auto
      qed
      have dr1[transfer_rule]: "(nrows A' - 1) = (dim_row A - 1)" unfolding nrows_def
        using AA' Mod_Type_Connect.dim_row_transfer_rule by force
      have ii'2[transfer_rule]: "Mod_Type_Connect.HMA_I i (?from_nat_rows i')"
        by (metis "**" Mod_Type_Connect.HMA_I_def i_le_m ii' le_neq_implies_less
            mod_type_class.to_nat_from_nat_id nrows_def)
      have ii'3[transfer_rule]: "Mod_Type_Connect.HMA_I i' (?from_nat_rows i')" 
        using ii' ii'2 by blast
      let ?BI_JNF = "(bezout_iterate_JNF (?interchange_A) (dim_row A - 1) i k bezout)"
      let ?BI_HA = "(bezout_iterate (?interchange_A') (nrows A' - 1) (?from_nat_rows i) (?from_nat_cols k) bezout)"
      have e_rw: "echelon_form_of_column_k_JNF bezout xa k = (?BI_JNF,i+1)"
        unfolding echelon_form_of_column_k_JNF_def n_def using False xa not_c1 by auto
      have e_rw2: "echelon_form_of_column_k bezout ya k = (?BI_HA,i+1)"
        unfolding echelon_form_of_column_k_def Let_def n'_def using * ya ** ii' by auto
      have s[transfer_rule]: "Mod_Type_Connect.HMA_M (swaprows i' n A) (interchange_rows A' (?from_nat_rows i') n')" 
        by transfer_prover
      have n_CARD: "(nrows A' - 1) < CARD('m)" unfolding nrows_def by auto
      note a[transfer_rule] = HMA_bezout_iterate[OF n_CARD]
      have BI[transfer_rule]:"Mod_Type_Connect.HMA_M ?BI_JNF ?BI_HA" unfolding ii' dr1 
        by (rule HMA_bezout_iterate'[OF _ s ii'3 kk'], insert n_CARD, transfer', simp)
      thus ?thesis using e_rw e_rw2 bb'
        by (metis (mono_tags, lifting) AA' False Mod_Type_Connect.dim_row_transfer_rule 
            atLeastLessThan_iff dual_order.trans order_less_imp_le rel_prod_inject)
    qed
  qed
qed

corollary HMA_echelon_form_of_column_k'[transfer_rule]: 
  assumes k: "k<CARD('n)" and "iCARD('m)"
  and "(Mod_Type_Connect.HMA_M :: _  int ^ 'n :: mod_type ^ 'm :: mod_type  _) A A'"
  shows "(rel_prod (Mod_Type_Connect.HMA_M) (λa b. a=b  aCARD('m))) 
  (echelon_form_of_column_k_JNF bezout (A,i) k)  
  (echelon_form_of_column_k bezout (A',i) k)"
  using assms HMA_echelon_form_of_column_k[OF k] unfolding rel_fun_def by force

lemma HMA_foldl_echelon_form_of_column_k:
  assumes k: "kCARD('n)"
  shows "((Mod_Type_Connect.HMA_M :: _  int ^ 'n :: mod_type ^ 'm :: mod_type  _) ===> (=)
    ===> (rel_prod (Mod_Type_Connect.HMA_M) (λa b. a=b  aCARD('m)))) 
  (λA bezout. (foldl (echelon_form_of_column_k_JNF bezout) (A,0) [0..<k]))  
  (λA bezout. (foldl (echelon_form_of_column_k bezout) (A,0) [0..<k]))"
proof (intro rel_funI, goal_cases)
  case (1 A A' bezout bezout')
  then show ?case using assms
  proof (induct k arbitrary: A A' )
    case 0
    then show ?case by auto
  next
     case (Suc k)
    note AA'[transfer_rule] = "Suc.prems"(1)
    note bb'[transfer_rule] = "Suc.prems"(2)
    note Suc_k_less_m = "Suc.prems"(3)
    let ?foldl_JNF = "foldl (echelon_form_of_column_k_JNF bezout) (A,0)"
    let ?foldl_HA = "foldl (echelon_form_of_column_k bezout') (A',0)"
    have set_rw: "[0..<Suc k] = [0..<k] @ [k]" by auto
    have f_JNF: "?foldl_JNF [0..<Suc k] = echelon_form_of_column_k_JNF bezout (?foldl_JNF [0..<k]) k" 
      by auto
    have f_HA: "?foldl_HA [0..<Suc k] = echelon_form_of_column_k bezout' (?foldl_HA [0..<k]) k" 
      by auto
    have hyp[transfer_rule]: "rel_prod Mod_Type_Connect.HMA_M (λa b. a=b  aCARD('m)) (?foldl_JNF [0..<k]) (?foldl_HA [0..<k])"
      by (rule Suc.hyps[OF AA'], insert Suc.prems, auto)
    show ?case unfolding f_JNF unfolding f_HA bb' using HMA_echelon_form_of_column_k'
      by (smt "1"(2) Suc_k_less_m Suc_le_lessD hyp rel_prod.cases)
  qed
qed



lemma HMA_echelon_form_of_upt_k[transfer_rule]:
  assumes k: "k<CARD('n)"
  shows "((Mod_Type_Connect.HMA_M :: _  int ^ 'n :: mod_type ^ 'm :: mod_type  _) ===> (=)
    ===> (Mod_Type_Connect.HMA_M)) 
  (λA bezout. echelon_form_of_upt_k_JNF A k bezout)  
  (λA bezout. echelon_form_of_upt_k A k bezout)
  "
proof (intro rel_funI, goal_cases)
  case (1 A A' bezout bezout')
  have k': "Suc k  CARD('n)" using k by auto
  have rel_foldl: "(rel_prod (Mod_Type_Connect.HMA_M) (λa b. a=b  aCARD('m))) 
  (foldl (echelon_form_of_column_k_JNF bezout) (A,0) [0..<Suc k])  
  (foldl (echelon_form_of_column_k bezout) (A',0) [0..<Suc k])"
    using HMA_foldl_echelon_form_of_column_k[OF k'] by (smt "1"(1) rel_fun_def)
  then show ?case using assms unfolding echelon_form_of_upt_k_JNF_def echelon_form_of_upt_k_def    
    by (metis (no_types, lifting) "1"(2) prod.collapse rel_prod_inject)
qed
 

lemma HMA_echelon_form_of[transfer_rule]:
  shows "((Mod_Type_Connect.HMA_M :: _  int ^ 'n :: mod_type ^ 'm :: mod_type  _) ===> (=)
    ===> (Mod_Type_Connect.HMA_M)) 
  (λA bezout. echelon_form_of_JNF A bezout)  
  (λA bezout. echelon_form_of A bezout)
  "
proof (intro rel_funI, goal_cases)
  case (1 A A' bezout bezout')
  note AA'[transfer_rule] = 1(1)
  note bb'[transfer_rule] = 1(2)
  have *: "(dim_col A - 1) < CARD('n)" using 1
    using Mod_Type_Connect.dim_col_transfer_rule by force
  note **[transfer_rule] = HMA_echelon_form_of_upt_k[OF *]
  have [transfer_rule]: "(ncols A' - 1) = (dim_col A - 1)"
    by (metis "1"(1) Mod_Type_Connect.dim_col_transfer_rule ncols_def)
  have [transfer_rule]: "(dim_col A - 1) = (dim_col A - 1)" ..
  show ?case unfolding echelon_form_of_def echelon_form_of_JNF_def bb'
    by (metis (mono_tags) "**" "1"(1) ‹ncols A' - 1 = dim_col A - 1 rel_fun_def)
qed
end


context
begin

private lemma echelon_form_of_euclidean_invertible_mod_type:
  fixes A::"int mat"
  assumes "A  carrier_mat CARD('m::mod_type) CARD('n::mod_type)"
  shows "P. invertible_mat P  P  carrier_mat (CARD('m::mod_type)) (CARD('m::mod_type)) 
     P * A = echelon_form_of_JNF A euclid_ext2 
     echelon_form_JNF (echelon_form_of_JNF A euclid_ext2)"
proof -
  define A' where "A' = (Mod_Type_Connect.to_hmam A :: int ^'n :: mod_type ^'m :: mod_type)"
  have AA'[transfer_rule]: "Mod_Type_Connect.HMA_M A A'"
    unfolding Mod_Type_Connect.HMA_M_def using assms A'_def by auto   
  have [transfer_rule]: "Mod_Type_Connect.HMA_M 
    (echelon_form_of_JNF A euclid_ext2) (echelon_form_of A' euclid_ext2)" 
    by transfer_prover  
  have "P. invertible P  P**A' = (echelon_form_of A' euclid_ext2) 
          echelon_form (echelon_form_of A' euclid_ext2)"
    by (rule echelon_form_of_euclidean_invertible)    
  thus ?thesis by (transfer, auto)
qed 


private lemma echelon_form_of_euclidean_invertible_nontriv_mod_ring:
  fixes A::"int mat"
  assumes "A  carrier_mat CARD('m::nontriv mod_ring) CARD('n::nontriv mod_ring)"
  shows "P. invertible_mat P  P  carrier_mat (CARD('m)) (CARD('m)) 
     P * A = echelon_form_of_JNF A euclid_ext2 
     echelon_form_JNF (echelon_form_of_JNF A euclid_ext2)"
  using assms echelon_form_of_euclidean_invertible_mod_type by (smt CARD_mod_ring)

(*We internalize both sort constraints in one step*)
lemmas echelon_form_of_euclidean_invertible_nontriv_mod_ring_internalized = 
  echelon_form_of_euclidean_invertible_nontriv_mod_ring[unfolded CARD_mod_ring, 
      internalize_sort "'m::nontriv", internalize_sort "'b::nontriv"]

context
  fixes m::nat and n::nat
  assumes local_typedef1: "(Rep :: ('b  int)) Abs. type_definition Rep Abs {0..<m :: int}"
  assumes local_typedef2: "(Rep :: ('c  int)) Abs. type_definition Rep Abs {0..<n :: int}"
  and m: "m>1"
  and n: "n>1"
begin

lemma echelon_form_of_euclidean_invertible_nontriv_mod_ring_aux:
  fixes A::"int mat"
  assumes "A  carrier_mat m n"
  shows "P. invertible_mat P  P  carrier_mat m m
     P * A = echelon_form_of_JNF A euclid_ext2 
     echelon_form_JNF (echelon_form_of_JNF A euclid_ext2)"
 using echelon_form_of_euclidean_invertible_nontriv_mod_ring_internalized
    [OF type_to_set2(1)[OF local_typedef1 local_typedef2] 
        type_to_set1(1)[OF local_typedef1 local_typedef2]]
  using assms 
  using type_to_set1(2) local_typedef1 local_typedef2 n m by metis 

end


(*Canceling the first local type definitions*)
context
begin

(*Canceling the first*)

private lemma echelon_form_of_euclidean_invertible_cancelled_first:
"Rep Abs. type_definition Rep Abs {0..<int n}  1 < m  1 < n 
  A  carrier_mat m n  P. invertible_mat P  P  carrier_mat m m
   P * (A::int mat) = echelon_form_of_JNF A euclid_ext2  echelon_form_JNF (echelon_form_of_JNF A euclid_ext2)"
  using echelon_form_of_euclidean_invertible_nontriv_mod_ring_aux[cancel_type_definition, of m n A]
  by force  

(*Canceling the second*)
private lemma echelon_form_of_euclidean_invertible_cancelled_both:
"1 < m  1 < n  A  carrier_mat m n  P. invertible_mat P  P  carrier_mat m m 
   P * (A::int mat) = echelon_form_of_JNF A euclid_ext2  echelon_form_JNF (echelon_form_of_JNF A euclid_ext2)"
  using echelon_form_of_euclidean_invertible_cancelled_first[cancel_type_definition, of n m A]
  by force

(*The final result in JNF*)

lemma echelon_form_of_euclidean_invertible':
 fixes A::"int mat"
  assumes "A  carrier_mat m n" 
  and "1 < m" and "1 < n" (*Required from the mod_type restrictions*)
  shows "P. invertible_mat P 
        P  carrier_mat m m  P * A = echelon_form_of_JNF A euclid_ext2 
         echelon_form_JNF (echelon_form_of_JNF A euclid_ext2)"  
  using echelon_form_of_euclidean_invertible_cancelled_both assms by auto
end
end

context mod_operation
begin

definition "FindPreHNF_rectangular A 
  =   (let m = dim_row A; n = dim_col A in 
  if m < 2  n = 0 then A else ― ‹ No operations are carried out if m = 1 ›
  if n = 1 then 
        let non_zero_positions = filter (λi. A $$ (i,0)  0) [1..<dim_row A] in
        if non_zero_positions = [] then A
        else let A' = (if A$$(0,0)  0 then A else let i = non_zero_positions ! 0 in swaprows 0 i A)
            in reduce_below_impl 0 non_zero_positions 0 A'
  else (echelon_form_of_JNF A euclid_ext2))"

text ‹This is the (non-efficient) HNF algorithm obtained from the echelon form and Hermite normal 
form AFP entries›

definition "HNF_algorithm_from_HA A 
            = Hermite_of_list_of_rows (FindPreHNF_rectangular A) [0..<(dim_row A)]"

(*
  Now we can combine FindPreHNF_rectangular, FindPreHNF and Hermite_of_list_of_rows to get
  an algorithm to compute the HNF of any matrix (if it is square and invertible, then the HNF is
  computed reducing entries modulo D)
*)

text ‹Now we can combine @{text"FindPreHNF_rectangular"}, @{text"FindPreHNF"}
  and @{text"Hermite_of_list_of_rows"} to get an algorithm to compute the HNF of any matrix
  (if it is square and invertible, then the HNF is computed reducing entries modulo D)›

definition "HNF_algorithm abs_flag A = 
  (let m = dim_row A; n = dim_col A in
  if m  n then Hermite_of_list_of_rows (FindPreHNF_rectangular A) [0..<m]
  else
    let D = abs (det_int A) in
    if D = 0 then Hermite_of_list_of_rows (FindPreHNF_rectangular A) [0..<m]
    else 
      let A' = A @r D m 1m n;
          E = FindPreHNF abs_flag D A';
          H = Hermite_of_list_of_rows E [0..<m+n]
      in mat_of_rows n (map (Matrix.row H) [0..<m]))"

end

declare mod_operation.FindPreHNF_rectangular_def[code]
declare mod_operation.HNF_algorithm_from_HA_def[code]
declare mod_operation.HNF_algorithm_def[code]

context proper_mod_operation
begin

(*With some work, we could get this lemma for matrices whose elements belong to a Bézout domain*)
lemma FindPreHNF_rectangular_soundness:
  fixes A::"int mat"
  assumes A: "A  carrier_mat m n" 
  shows "P. invertible_mat P  P  carrier_mat m m  P * A = FindPreHNF_rectangular A 
     echelon_form_JNF (FindPreHNF_rectangular A)"  
proof (cases "m < 2  n = 0")
  case True
  then show ?thesis
    by (smt A FindPreHNF_rectangular_def carrier_matD echelon_form_JNF_1xn echelon_form_mx0
        invertible_mat_one left_mult_one_mat one_carrier_mat)
next
  case False 
  have m1: "m>1" using False by auto
  have n0: "n>0" using False by auto
  show ?thesis
  proof (cases "n=1")
    case True note n1 = True
    let ?nz = "filter (λi. A $$ (i,0)  0) [1..<dim_row A]" 
    let ?A' = "(if A$$(0,0)  0 then A else let i = ?nz ! 0 in swaprows 0 i A)"
    have A': "?A'  carrier_mat m n" using A by auto
    have A'00: "?A' $$ (0,0)  0" if "?nz  []" 
      by (smt True assms carrier_matD index_mat_swaprows(1) length_greater_0_conv m1
          mem_Collect_eq nat_SN.gt_trans nth_mem set_filter that zero_less_one_class.zero_less_one)
    have e_r: "echelon_form_JNF (reduce_below 0 ?nz 0 ?A')" if nz_not_empty: "?nz  []" 
    proof (rule echelon_form_JNF_mx1)
      show "(reduce_below 0 ?nz 0 ?A')  carrier_mat m n"  using A reduce_below by auto
      have "(reduce_below 0 ?nz 0 ?A') $$ (i,0) = 0" if i: "i  {1..<m}" for i
      proof (cases "i  set ?nz")
        case True
        show ?thesis
          by (rule reduce_below_0_D0[OF A' _ _ A'00 True], insert m1 n0 True A nz_not_empty, auto)
      next
        case False
        have "(reduce_below 0 ?nz 0 ?A') $$ (i,0) = ?A' $$ (i,0)" 
          by (rule reduce_below_preserves_D0[OF A' _ _ A'00 False], insert m1 n0 True A i nz_not_empty, auto)
        also have "... = 0" using False n1 assms that by auto
        finally show ?thesis .
      qed
      thus "i  {1..<m}. (reduce_below 0 ?nz 0 ?A') $$ (i,0) = 0"
        by simp
    qed (insert True, simp)
    have "P. invertible_mat P  P  carrier_mat m m  reduce_below 0 ?nz 0 ?A' = P * ?A'" 
      by (rule reduce_below_invertible_mat_D0[OF A'], insert m1 n0 True A, auto)
    moreover have "P. invertible_mat P  P  carrier_mat m m  ?A' = P * A"   if "?nz  []"
      using A A'_swaprows_invertible_mat m1 that by blast 
    ultimately have e_inv: "P. invertible_mat P  P  carrier_mat m m  reduce_below 0 ?nz 0 ?A' = P * A"
      if "?nz  []"
      by (smt that A assoc_mult_mat invertible_mult_JNF mult_carrier_mat)
    have e_r1: "echelon_form_JNF A" if nz_empty: "?nz = []" 
    proof (rule echelon_form_JNF_mx1[OF A])
      show "i{1..<m}. A $$ (i, 0) = 0 " using nz_empty
        by (metis (mono_tags, lifting) A carrier_matD(1) empty_filter_conv set_upt)
    qed (insert n1, simp)
    have e_inv1: "P. invertible_mat P  P  carrier_mat m m  A = P * A"
      by (metis A invertible_mat_one left_mult_one_mat one_carrier_mat)
    have "FindPreHNF_rectangular A = (if ?nz = [] then A else reduce_below_impl 0 ?nz 0 ?A')"
      unfolding FindPreHNF_rectangular_def Let_def using m1 n1 A True by auto
    also have "reduce_below_impl 0 ?nz 0 ?A' = reduce_below 0 ?nz 0 ?A'"
      by (rule reduce_below_impl[OF _ _ _ _ A'], insert m1 n0 A, auto)
    finally show ?thesis using e_inv e_r e_r1 e_inv1 by metis
  next
    case False
    have f_rw: "FindPreHNF_rectangular A = echelon_form_of_JNF A euclid_ext2"
      unfolding FindPreHNF_rectangular_def Let_def using m1 n0 A False by auto
    show ?thesis unfolding f_rw 
      by (rule echelon_form_of_euclidean_invertible'[OF A], insert False n0 m1, auto)
  qed
qed

lemma HNF_algorithm_from_HA_soundness:
  assumes A: "A  carrier_mat m n"
  shows "Hermite_JNF (range ass_function_euclidean) (λc. range (res_int c)) (HNF_algorithm_from_HA A)
     (P. P  carrier_mat m m  invertible_mat P  (HNF_algorithm_from_HA A) = P * A)"
proof -
  have m: "dim_row A = m" using A by auto
  have "(P. P  carrier_mat m m  invertible_mat P  (HNF_algorithm_from_HA A) = P * (FindPreHNF_rectangular A))"
    unfolding HNF_algorithm_from_HA_def m
  proof (rule invertible_Hermite_of_list_of_rows)
    show "FindPreHNF_rectangular A  carrier_mat m n"
      by (smt A FindPreHNF_rectangular_soundness mult_carrier_mat)
    show "echelon_form_JNF (FindPreHNF_rectangular A)" 
      using FindPreHNF_rectangular_soundness by blast
  qed
  moreover have "(P. P  carrier_mat m m  invertible_mat P  (FindPreHNF_rectangular A) = P * A)"    
    by (metis A FindPreHNF_rectangular_soundness)
  ultimately have "(P. P  carrier_mat m m  invertible_mat P  (HNF_algorithm_from_HA A) = P * A)"
    by (smt assms assoc_mult_mat invertible_mult_JNF mult_carrier_mat)
  moreover have "Hermite_JNF (range ass_function_euclidean) (λc. range (res_int c)) (HNF_algorithm_from_HA A)"
    by (metis A FindPreHNF_rectangular_soundness HNF_algorithm_from_HA_def m 
        Hermite_Hermite_of_list_of_rows mult_carrier_mat)
  ultimately show ?thesis by simp
qed


text ‹Soundness theorem for any matrix›
lemma HNF_algorithm_soundness:
  assumes A: "A  carrier_mat m n"
  shows "Hermite_JNF (range ass_function_euclidean) (λc. range (res_int c)) (HNF_algorithm abs_flag A)
     (P. P  carrier_mat m m  invertible_mat P  (HNF_algorithm abs_flag A) = P * A)"
proof (cases "mn  Determinant.det A = 0")
  case True
  have H_rw: "HNF_algorithm abs_flag A = Hermite_of_list_of_rows (FindPreHNF_rectangular A) [0..<m]"
    using True A unfolding HNF_algorithm_def Let_def by auto
  have "(P. P  carrier_mat m m  invertible_mat P  (HNF_algorithm abs_flag A) = P * (FindPreHNF_rectangular A))"
    unfolding H_rw
  proof (rule invertible_Hermite_of_list_of_rows)
    show "FindPreHNF_rectangular A  carrier_mat m n"
      by (smt A FindPreHNF_rectangular_soundness mult_carrier_mat)
    show "echelon_form_JNF (FindPreHNF_rectangular A)" 
      using FindPreHNF_rectangular_soundness by blast
  qed
  moreover have "(P. P  carrier_mat m m  invertible_mat P  (FindPreHNF_rectangular A) = P * A)"    
    by (metis A FindPreHNF_rectangular_soundness)
  ultimately have "(P. P  carrier_mat m m  invertible_mat P  (HNF_algorithm abs_flag A) = P * A)"
    by (smt assms assoc_mult_mat invertible_mult_JNF mult_carrier_mat)
  moreover have "Hermite_JNF (range ass_function_euclidean) (λc. range (res_int c)) (HNF_algorithm abs_flag A)"
    by (metis A FindPreHNF_rectangular_soundness H_rw Hermite_Hermite_of_list_of_rows mult_carrier_mat)
  ultimately show ?thesis by simp
next
  case False
  hence mn: "m=n" and det_A_not0:"(Determinant.det A)  0" by auto
  have inv_RAT_A: "invertible_mat (map_mat rat_of_int A)"
  proof -
    have "det (map_mat rat_of_int A)  0" using det_A_not0 by auto
    thus ?thesis 
      by (metis False assms dvd_field_iff invertible_iff_is_unit_JNF map_carrier_mat)
  qed
  have "HNF_algorithm abs_flag A = Hermite_mod_det abs_flag A"
    unfolding HNF_algorithm_def Hermite_mod_det_def Let_def using False A by simp    
  then show ?thesis using Hermite_mod_det_soundness[OF mn A inv_RAT_A] by auto
qed
end


text ‹New predicate of soundness of a HNF algorithm, without providing explicitly the transformation matrix.›

definition "is_sound_HNF' algorithm associates res 
    = (A. let H = algorithm A; m = dim_row A; n = dim_col A in Hermite_JNF associates res H 
         H  carrier_mat m n  (P. P  carrier_mat m m  invertible_mat P  A = P * H))"

lemma is_sound_HNF_conv:
  assumes s: "is_sound_HNF' algorithm associates res"
  shows "is_sound_HNF (λA. let H = algorithm A in (SOME P. P  carrier_mat (dim_row A) (dim_row A)
     invertible_mat P  A = P * H, H)) associates res"
proof (unfold is_sound_HNF_def Let_def prod.case, rule allI)
  fix A::"'a mat"
  define m where "m = dim_row A"
  obtain P where P: "P  carrier_mat m m  invertible_mat P  A = P * (algorithm A)" 
    using s unfolding is_sound_HNF'_def Let_def m_def by auto
  let ?some_P = "(SOME P. P  carrier_mat m m  invertible_mat P  A = P * algorithm A)"
  have some_P: "?some_P  carrier_mat m m  invertible_mat ?some_P  A = ?some_P * algorithm A"
    by (smt P verit_sko_ex_indirect)
  moreover have "algorithm A  carrier_mat (dim_row A) (dim_col A)"
    and  "Hermite_JNF associates res (algorithm A)" using s unfolding is_sound_HNF'_def Let_def by auto    
  ultimately show "?some_P  carrier_mat m m  algorithm A  carrier_mat m (dim_col A) 
     invertible_mat ?some_P  A = ?some_P * algorithm A  Hermite_JNF associates res (algorithm A)"
    unfolding is_sound_HNF_def Let_def m_def by (auto split: prod.split)
qed

context proper_mod_operation
begin
corollary is_sound_HNF'_HNF_algorithm:
   "is_sound_HNF' (HNF_algorithm abs_flag) (range ass_function_euclidean) (λc. range (res_int c))"  
proof -
  have "Hermite_JNF (range ass_function_euclidean) (λc. range (res_int c)) (HNF_algorithm abs_flag A)" for A
    using HNF_algorithm_soundness by blast
  moreover have "HNF_algorithm abs_flag A  carrier_mat (dim_row A) (dim_col A)" for A
    by (metis HNF_algorithm_soundness carrier_matI mult_carrier_mat)
  moreover have "P. P  carrier_mat (dim_row A) (dim_row A)  invertible_mat P  A = P * HNF_algorithm abs_flag A" for A 
  proof -
    have "P. P  carrier_mat (dim_row A) (dim_row A)  invertible_mat P  HNF_algorithm abs_flag A = P *  A"
      using HNF_algorithm_soundness by blast
    from this obtain P where P: "P  carrier_mat (dim_row A) (dim_row A)" and inv_P: "invertible_mat P"
      and H_PA: "HNF_algorithm abs_flag A = P *  A" by blast
    obtain P' where PP': "inverts_mat P P'" and P'P: "inverts_mat P' P"
      using inv_P unfolding invertible_mat_def by auto
    have P': "P'  carrier_mat (dim_row A) (dim_row A) "
      by (metis P PP' P'P carrier_matD carrier_mat_triv index_mult_mat(3) index_one_mat(3) inverts_mat_def)
    moreover have inv_P': "invertible_mat P'"
      by (metis P' P'P PP' carrier_matD(1) carrier_matD(2) invertible_mat_def square_mat.simps)
    moreover have "A = P' * HNF_algorithm abs_flag A"
      by (smt H_PA P P'P assoc_mult_mat calculation(1) carrier_matD(1) carrier_matI inverts_mat_def left_mult_one_mat')
    ultimately show ?thesis by auto
  qed
  ultimately show ?thesis
    unfolding is_sound_HNF'_def Let_def by auto
qed


corollary is_sound_HNF'_HNF_algorithm_from_HA:
   "is_sound_HNF' (HNF_algorithm_from_HA) (range ass_function_euclidean) (λc. range (res_int c))"  
proof -
  have "Hermite_JNF (range ass_function_euclidean) (λc. range (res_int c)) (HNF_algorithm_from_HA A)" for A
    using HNF_algorithm_from_HA_soundness by blast
  moreover have "HNF_algorithm_from_HA A  carrier_mat (dim_row A) (dim_col A)" for A
    by (metis HNF_algorithm_from_HA_soundness carrier_matI mult_carrier_mat)
  moreover have "P. P  carrier_mat (dim_row A) (dim_row A)  invertible_mat P  A = P * HNF_algorithm_from_HA A" for A 
  proof -
    have "P. P  carrier_mat (dim_row A) (dim_row A)  invertible_mat P  HNF_algorithm_from_HA A = P *  A"
      using HNF_algorithm_from_HA_soundness by blast
    from this obtain P where P: "P  carrier_mat (dim_row A) (dim_row A)" and inv_P: "invertible_mat P"
      and H_PA: "HNF_algorithm_from_HA A = P *  A" by blast
    obtain P' where PP': "inverts_mat P P'" and P'P: "inverts_mat P' P"
      using inv_P unfolding invertible_mat_def by auto
    have P': "P'  carrier_mat (dim_row A) (dim_row A) "
      by (metis P PP' P'P carrier_matD carrier_mat_triv index_mult_mat(3) index_one_mat(3) inverts_mat_def)
    moreover have inv_P': "invertible_mat P'"
      by (metis P' P'P PP' carrier_matD(1) carrier_matD(2) invertible_mat_def square_mat.simps)
    moreover have "A = P' * HNF_algorithm_from_HA A"
      by (smt H_PA P P'P assoc_mult_mat calculation(1) carrier_matD(1) carrier_matI inverts_mat_def left_mult_one_mat')
    ultimately show ?thesis by auto
  qed
  ultimately show ?thesis
    unfolding is_sound_HNF'_def Let_def by auto
qed
end

text ‹Some work to make the algorithm executable›

definition find_non0' :: "nat  nat  'a::comm_ring_1 mat  nat option" where
  "find_non0' i k A = (let is = [i ..< dim_row A];
    Ais = filter (λj. A $$ (j, k)  0) is
    in case Ais of []  None | _  Some (Ais!0))"

lemma find_non0': 
  assumes A: "A  carrier_mat m n"
  and res: "find_non0' i k A = Some j"
  shows "A $$ (j,k)  0" "i  j" "j < dim_row A"
proof -
  let ?xs = "filter (λj. A $$ (j,k)  0) [i ..< dim_row A]"
  from res[unfolded find_non0'_def Let_def]
  have xs: "?xs  []" by (cases ?xs, auto)
  have j_in_xs: "j  set ?xs" using res unfolding find_non0'_def Let_def
    by (metis (no_types, lifting) length_greater_0_conv list.case(2) list.exhaust nth_mem option.simps(1) xs)
  show "A $$ (j,k)  0" "i  j" "j < dim_row A" using j_in_xs by auto+  
qed


lemma find_non0'_w_zero_before: 
  assumes A: "A  carrier_mat m n"
  and res: "find_non0' i k A = Some j"
  shows "j'{i..<j}. A $$ (j',k) = 0"
proof -
  let ?xs = "filter (λj. A $$ (j, k)  0) [i ..< dim_row A]"
  from res[unfolded find_non0'_def Let_def]
  have xs: "?xs  []" by (cases ?xs, auto)
  have j_in_xs: "j  set ?xs" using res unfolding find_non0'_def Let_def
    by (metis (no_types, lifting) length_greater_0_conv list.case(2) list.exhaust nth_mem option.simps(1) xs)
  have j_xs0: "j = ?xs ! 0"
    by (smt res[unfolded find_non0'_def Let_def] list.case(2) list.exhaust option.inject xs)
  show "j'{i..<j}. A $$ (j',k) = 0"
  proof (rule+, rule ccontr)
    fix j' assume j': "j' : {i..<j}" and Alj': "A $$ (j',k)  0"
    have j'j: "j'<j" using j' by auto
    have j'_in_xs: "j'  set ?xs" 
      by (metis (mono_tags, lifting) A Alj' Set.member_filter atLeastLessThan_iff filter_set
          find_non0'(3) j' nat_SN.gt_trans res set_upt)
    have l_rw: "[i..<dim_row A] = [i ..<j] @[j..<dim_row A]"
      using assms(1) assms(2) find_non0'(3) j' upt_append 
      by (metis atLeastLessThan_iff le_trans linorder_not_le) 
    have xs_rw: "?xs = filter (λj. A $$ (j,k)  0) ([i ..<j] @[j..<dim_row A])"
      using l_rw by auto
    hence "filter (λj. A $$ (j,k)  0) [i ..<j] = []" using j_xs0 
      by (metis (no_types, lifting) Set.member_filter atLeastLessThan_iff filter_append filter_set
          length_greater_0_conv nth_append nth_mem order_less_irrefl set_upt)
    thus False using j_xs0 j' j_xs0 
      by (metis Set.member_filter filter_empty_conv filter_set j'_in_xs set_upt)
  qed
qed


lemma find_non0'_LEAST: 
  assumes A: "A  carrier_mat m n"
  and res: "find_non0' i k A = Some j"
shows "j = (LEAST n. A $$ (n,k)  0  in)"
proof (rule Least_equality[symmetric])
  show " A $$ (j, k)  0  i  j" 
    using A res find_non0'[OF A] by auto
  show " y. A $$ (y, k)  0  i  y  j  y"
    by (meson A res atLeastLessThan_iff find_non0'_w_zero_before linorder_not_le)
qed

lemma echelon_form_of_column_k_JNF_code[code]:
  "echelon_form_of_column_k_JNF bezout (A,i) k = 
    (if (i = dim_row A)  (m  {i..<dim_row A}. A $$ (m, k) = 0) then (A, i) else 
        if (m{i+1..<dim_row A}. A $$ (m,k) = 0) then (A, i + 1) else
            let n = the (find_non0' i k A); 
                interchange_A = swaprows i n A
           in
            (bezout_iterate_JNF (interchange_A) (dim_row A - 1) i k bezout, i + 1))"
proof (cases "¬ ((i = dim_row A)  (m  {i..<dim_row A}. A $$ (m, k) = 0)) 
             ¬ (m{i+1..<dim_row A}. A $$ (m,k) = 0)")
  case True
  let ?n = "the (find_non0' i k A)"
  let ?interchange_A = "swaprows i ?n A"
  have f_rw: "(the (find_non0' i k A)) = (LEAST n. A $$ (n, k)  0  i  n)"
  proof (rule find_non0'_LEAST)
    have "find_non0' i k A  None" using True unfolding find_non0'_def Let_def
      by (auto split: list.split)
         (metis (mono_tags, lifting) atLeastLessThan_iff atLeastLessThan_upt empty_filter_conv)
    thus "find_non0' i k A = Some (the (find_non0' i k A))" by auto
  qed (auto)
  show ?thesis unfolding echelon_form_of_column_k_JNF_def Let_def f_rw using True by auto
next
  case False
  then show ?thesis unfolding echelon_form_of_column_k_JNF_def by auto
qed


subsection ‹Instantiation of the HNF-algorithm with modulo-operation›

text ‹We currently use a Boolean flag to indicate whether standard-mod or symmetric modulo
  should be used.›

lemma sym_mod: "proper_mod_operation sym_mod sym_div" 
  by (unfold_locales, auto simp: sym_mod_sym_div)

lemma standard_mod: "proper_mod_operation (mod) (div)" 
  by (unfold_locales, auto, intro HOL.nitpick_unfold(7))

definition HNF_algorithm :: "bool  int mat  int mat" where
  "HNF_algorithm use_sym_mod = (if use_sym_mod 
    then mod_operation.HNF_algorithm sym_mod False else mod_operation.HNF_algorithm (mod) True)" 

definition HNF_algorithm_from_HA :: "bool  int mat  int mat" where
  "HNF_algorithm_from_HA use_sym_mod = (if use_sym_mod 
    then mod_operation.HNF_algorithm_from_HA sym_mod else mod_operation.HNF_algorithm_from_HA (mod))"


corollary is_sound_HNF'_HNF_algorithm:
   "is_sound_HNF' (HNF_algorithm use_sym_mod) (range ass_function_euclidean) (λc. range (res_int c))"  
  using proper_mod_operation.is_sound_HNF'_HNF_algorithm[OF sym_mod]
    proper_mod_operation.is_sound_HNF'_HNF_algorithm[OF standard_mod]
  unfolding HNF_algorithm_def by (cases use_sym_mod, auto)

corollary is_sound_HNF'_HNF_algorithm_from_HA:
   "is_sound_HNF' (HNF_algorithm_from_HA use_sym_mod) (range ass_function_euclidean) (λc. range (res_int c))"  
  using proper_mod_operation.is_sound_HNF'_HNF_algorithm_from_HA[OF sym_mod]
    proper_mod_operation.is_sound_HNF'_HNF_algorithm_from_HA[OF standard_mod]
  unfolding HNF_algorithm_from_HA_def by (cases use_sym_mod, auto)


(*Examples:*)
(*Rectangular matrix (6x4)*)
value [code]"let A = mat_of_rows_list 4 (
  [[0,3,1,4],
   [7,1,0,0],
   [8,0,19,16],
   [2,0,0,3::int],
   [9,-3,2,5],
   [6,3,2,4]]) in
  show (HNF_algorithm True A)"

(*Rectangular matrix (4x6)*)

value [code]"let A = mat_of_rows_list 6 (
  [[0,3,1,4,8,7],
   [7,1,0,0,4,1],
   [8,0,19,16,33,5],
   [2,0,0,3::int,-5,8]]) in
  show (HNF_algorithm False A)"

(*Singular matrix*)
value [code]"let A = mat_of_rows_list 6 (
  [[0,3,1,4,8,7],
   [7,1,0,0,4,1],
   [8,0,19,16,33,5],
   [0,3,1,4,8,7],
   [2,0,0,3::int,-5,8],
   [2,4,6,8,10,12]]) in
  show (Determinant.det A, HNF_algorithm True A)"

(*Invertible matrix*)
value [code]"let A = mat_of_rows_list 6 (
  [[0,3,1,4,8,7],
   [7,1,0,0,4,1],
   [8,0,19,16,33,5],
   [5,6,1,2,8,7],
   [2,0,0,3::int,-5,8],
   [2,4,6,8,10,12]]) in
  show (Determinant.det A, HNF_algorithm True A)"

end

Theory LLL_Certification_via_HNF

section ‹LLL certification via Hermite normal forms›

text ‹In this file, we define the new certified approach and prove its soundness.›

theory LLL_Certification_via_HNF
  imports 
   LLL_Basis_Reduction.LLL_Certification
   Jordan_Normal_Form.DL_Rank
   HNF_Mod_Det_Soundness
begin


context LLL_with_assms
begin

lemma m_le_n: "mn"
proof -
  have "gs.lin_indpt (set (RAT fs_init))"
    using cof_vec_space.lin_indpt_list_def lin_dep by blast
  moreover have "gs.dim = n"
    by (simp add: gs.dim_is_n)
  moreover have "card (set (RAT fs_init)) = m"
    using LLL_invD(2) LLL_inv_initial_state cof_vec_space.lin_indpt_list_def distinct_card lin_dep
    by blast
  ultimately show ?thesis using gs.li_le_dim 
    by (metis cof_vec_space.lin_indpt_list_def gs.fin_dim lin_dep)
qed

end

text ‹This lemma is a generalization of the theorem named @{text "HNF_A_eq_HNF_PA"}, using
the new uniqueness statement of the HNF. We provide two versions, one
assuming the existence and the other one obtained from a sound algorithm.›

lemma HNF_A_eq_HNF_PA'_exist:
  fixes A::"int mat"
  assumes A: "A  carrier_mat n n" and inv_A: "invertible_mat (map_mat rat_of_int A)" 
    and inv_P: "invertible_mat P" and P: "P  carrier_mat n n"
    and HNF_H1: "Hermite_JNF associates res H1"
    and H1: "H1  carrier_mat n n"
    and HNF_H2: "Hermite_JNF associates res H2"
    and H2: "H2  carrier_mat n n"
    and sound_HNF1: "P1. P1  carrier_mat n n  invertible_mat P1  (P * A) = P1 * H1"
    and sound_HNF2: "P2. P2  carrier_mat n n  invertible_mat P2  A = P2 * H2"
  shows "H1 = H2"
proof -
  obtain inv_P where P_inv_P: "inverts_mat P inv_P" and inv_P_P: "inverts_mat inv_P P"
    and inv_P: "inv_P  carrier_mat n n"
    using P inv_P obtain_inverse_matrix by blast
  obtain P1 where P1: "P1  carrier_mat n n" and inv_P1: "invertible_mat P1" and P1_H1: "P* A = P1 * H1"
    using sound_HNF1 by auto
  obtain P2 where P2: "P2  carrier_mat n n" and inv_P2: "invertible_mat P2" and P2_H2: "A = P2 * H2"
    using sound_HNF2 by auto
  have invertible_inv_P: "invertible_mat inv_P"
      using P_inv_P inv_P inv_P_P invertible_mat_def square_mat.simps by blast
  have P_A_P1_H1: "P * A = P1 * H1" using P1_H1 P2_H2 unfolding is_sound_HNF_def Let_def
    by (metis (mono_tags, lifting) case_prod_conv)
  hence "A = inv_P * (P1 * H1)"
    by (smt A P inv_P_P inv_P assoc_mult_mat carrier_matD(1) inverts_mat_def left_mult_one_mat)
  hence A_inv_P_P1_H1: "A = (inv_P * P1) * H1" using P P1_H1 assoc_mult_mat inv_P H1 P1 by auto
  have invertible_inv_P_P1: "invertible_mat (inv_P * P1)"
    by (rule invertible_mult_JNF[OF inv_P P1 invertible_inv_P inv_P1])   
  show ?thesis
  proof (rule HNF_unique_generalized_JNF[OF A _ H1 P2 H2 A_inv_P_P1_H1 P2_H2 
        inv_A invertible_inv_P_P1 inv_P2 HNF_H1 HNF_H2])
    show "inv_P * P1  carrier_mat n n"
      by (metis carrier_matD(1) carrier_matI index_mult_mat(2) inv_P
          invertible_inv_P_P1 invertible_mat_def square_mat.simps)    
  qed
qed


corollary HNF_A_eq_HNF_PA':
  fixes A::"int mat"
  assumes A: "A  carrier_mat n n" and inv_A: "invertible_mat (map_mat rat_of_int A)" 
    and inv_P: "invertible_mat P" and P: "P  carrier_mat n n"
    and sound_HNF: "is_sound_HNF HNF associates res"
    and P1_H1: "(P1,H1) = HNF (P*A)"
    and P2_H2: "(P2,H2) = HNF A"
  shows "H1 = H2" 
proof -
  have H1: "H1  carrier_mat n n"
    by (smt P1_H1 A P carrier_matD index_mult_mat is_sound_HNF_def prod.sel(2) sound_HNF split_beta)
  have H2: "H2  carrier_mat n n"
    by (smt P2_H2 A carrier_matD index_mult_mat is_sound_HNF_def prod.sel(2) sound_HNF split_beta)
  have HNF_H1: "Hermite_JNF associates res H1" 
    by (smt P1_H1 is_sound_HNF_def prod.sel(2) sound_HNF split_beta)
  have HNF_H2: "Hermite_JNF associates res H2"
    by (smt P2_H2 is_sound_HNF_def prod.sel(2) sound_HNF split_beta)
  have sound_HNF1: "P1. P1  carrier_mat n n  invertible_mat P1  (P * A) = P1 * H1"
    using sound_HNF P1_H1 unfolding is_sound_HNF_def Let_def
    by (metis (mono_tags, lifting) P carrier_matD(1) index_mult_mat(2) old.prod.simps(2))
  have sound_HNF2: "P2. P2  carrier_mat n n  invertible_mat P2  A = P2 * H2"
    using sound_HNF P1_H1 unfolding is_sound_HNF_def Let_def
    by (metis (mono_tags, lifting) A P2_H2 carrier_matD(1) old.prod.simps(2))
  show ?thesis 
    by (rule HNF_A_eq_HNF_PA'_exist[OF A inv_A inv_P P HNF_H1 H1 HNF_H2 H2 sound_HNF1 sound_HNF2])
qed


context LLL_with_assms
begin


lemma certification_via_eq_HNF2_exist:
  assumes HNF_H1: "Hermite_JNF associates res H1"
    and H1: "H1  carrier_mat n n"
    and HNF_H2: "Hermite_JNF associates res H2"
    and H2: "H2  carrier_mat n n"
    and sound_HNF1: "P1. P1  carrier_mat n n  invertible_mat P1  (mat_of_rows n fs_init) = P1 * H1"
    and sound_HNF2: "P2. P2  carrier_mat n n  invertible_mat P2  (mat_of_rows n gs) = P2 * H2"
    and gs: "set gs  carrier_vec n" 
    and l: "lattice_of fs_init = lattice_of gs"
    and mn: "m = n" and len_gs: "length gs = n" (*For the moment, only for square matrices*)
  shows "H1 = H2"
proof -
  have "P  carrier_mat n n. invertible_mat P  mat_of_rows n fs_init = P * mat_of_rows n gs"    
    by (rule eq_lattice_imp_mat_mult_invertible_rows[OF fs_init gs lin_dep len[unfolded mn] len_gs l])
  from this obtain P where P: "P  carrier_mat n n" and inv_P: "invertible_mat P"
    and fs_P_gs: "mat_of_rows n fs_init = P * mat_of_rows n gs" by auto
   obtain P1 where P1: "P1  carrier_mat n n" and inv_P1: "invertible_mat P1" and P1_H1: "(mat_of_rows n fs_init) = P1 * H1"
    using sound_HNF1 by auto
  obtain P2 where P2: "P2  carrier_mat n n" and inv_P2: "invertible_mat P2" and P2_H2: "(mat_of_rows n gs) = P2 * H2"
    using sound_HNF2 by auto
  have P1_H1_2: "P * mat_of_rows n gs = P1 * H1"
    using P1_H1 fs_P_gs by auto
  have gs_carrier: "mat_of_rows n gs  carrier_mat n n" by (simp add: len_gs carrier_matI)
  show ?thesis
  proof (rule HNF_A_eq_HNF_PA'_exist[OF gs_carrier _ inv_P P HNF_H1 H1 HNF_H2 H2 _ sound_HNF2])
    from inv_P obtain P' where PP': "inverts_mat P P'" and P'P: "inverts_mat P' P"
      using invertible_mat_def by blast
    let ?RAT = "of_int_hom.mat_hom :: int mat  rat mat"
    have det_RAT_fs_init: "det (?RAT (mat_of_rows n fs_init))  0"
    proof (rule gs.lin_indpt_rows_imp_det_not_0)
      show "?RAT (mat_of_rows n fs_init)  carrier_mat n n"
        using len map_carrier_mat mat_of_rows_carrier(1) mn by blast
      have rw: "Matrix.rows (?RAT (mat_of_rows n fs_init)) = RAT fs_init"
        by (metis cof_vec_space.lin_indpt_list_def fs_init lin_dep mat_of_rows_map rows_mat_of_rows)
      thus "gs.lin_indpt (set (Matrix.rows (?RAT (mat_of_rows n fs_init))))" 
        by (insert lin_dep, simp add: cof_vec_space.lin_indpt_list_def)
      show "distinct (Matrix.rows (?RAT (mat_of_rows n fs_init)))"
        using rw cof_vec_space.lin_indpt_list_def lin_dep by auto
    qed
    hence d: "det (?RAT (mat_of_rows n fs_init)) dvd 1" using dvd_field_iff by blast
    hence inv_RAT_fs_init: "invertible_mat (?RAT (mat_of_rows n fs_init))"
      using invertible_iff_is_unit_JNF by (metis mn len map_carrier_mat mat_of_rows_carrier(1))
    have "invertible_mat (?RAT P)"
      by (metis P dvd_field_iff inv_P invertible_iff_is_unit_JNF map_carrier_mat 
          not_is_unit_0 of_int_hom.hom_0 of_int_hom.hom_det)
    have "det (?RAT (mat_of_rows n fs_init)) = det (?RAT P) * det (?RAT (mat_of_rows n gs))"
      by (metis Determinant.det_mult P fs_P_gs gs_carrier of_int_hom.hom_det of_int_hom.hom_mult)
    hence "det (?RAT (mat_of_rows n gs))  0" using d by auto 
    thus "invertible_mat (?RAT (mat_of_rows n gs))"
      by (meson dvd_field_iff gs_carrier invertible_iff_is_unit_JNF map_carrier_mat)
    show "P1. P1  carrier_mat n n  invertible_mat P1  P * mat_of_rows n gs = P1 * H1"
      using P1 P1_H1_2 inv_P1 by blast
  qed
qed

lemma certification_via_eq_HNF2:
  assumes sound_HNF: "is_sound_HNF HNF associates res"
    and P1_H1: "(P1,H1) = HNF (mat_of_rows n fs_init)"
    and P2_H2: "(P2,H2) = HNF (mat_of_rows n gs)"    
    and gs: "set gs  carrier_vec n" 
    and l: "lattice_of fs_init = lattice_of gs"
    and mn: "m = n" and len_gs: "length gs = n" (*For the moment, only for square matrices*)
  shows "H1 = H2"
proof -
  have "P  carrier_mat n n. invertible_mat P  mat_of_rows n fs_init = P * mat_of_rows n gs"    
    by (rule eq_lattice_imp_mat_mult_invertible_rows[OF fs_init gs lin_dep len[unfolded mn] len_gs l])
  from this obtain P where P: "P  carrier_mat n n" and inv_P: "invertible_mat P"
    and fs_P_gs: "mat_of_rows n fs_init = P * mat_of_rows n gs" by auto
  have P1_H1_2: "(P1,H1) = HNF (P * mat_of_rows n gs)" using fs_P_gs P1_H1 by auto  
  have gs_carrier: "mat_of_rows n gs  carrier_mat n n" by (simp add: len_gs carrier_matI)
  show ?thesis
  proof (rule HNF_A_eq_HNF_PA'[OF gs_carrier _ inv_P P sound_HNF P1_H1_2 P2_H2])
    from inv_P obtain P' where PP': "inverts_mat P P'" and P'P: "inverts_mat P' P"
      using invertible_mat_def by blast
    let ?RAT = "of_int_hom.mat_hom :: int mat  rat mat"
    have det_RAT_fs_init: "det (?RAT (mat_of_rows n fs_init))  0"
    proof (rule gs.lin_indpt_rows_imp_det_not_0)
      show "?RAT (mat_of_rows n fs_init)  carrier_mat n n"
        using len map_carrier_mat mat_of_rows_carrier(1) mn by blast
      have rw: "Matrix.rows (?RAT (mat_of_rows n fs_init)) = RAT fs_init"
        by (metis cof_vec_space.lin_indpt_list_def fs_init lin_dep mat_of_rows_map rows_mat_of_rows)
      thus "gs.lin_indpt (set (Matrix.rows (?RAT (mat_of_rows n fs_init))))" 
        by (insert lin_dep, simp add: cof_vec_space.lin_indpt_list_def)
      show "distinct (Matrix.rows (?RAT (mat_of_rows n fs_init)))"
        using rw cof_vec_space.lin_indpt_list_def lin_dep by auto
    qed
    hence d: "det (?RAT (mat_of_rows n fs_init)) dvd 1" using dvd_field_iff by blast
    hence inv_RAT_fs_init: "invertible_mat (?RAT (mat_of_rows n fs_init))"
      using invertible_iff_is_unit_JNF by (metis mn len map_carrier_mat mat_of_rows_carrier(1))
    have "invertible_mat (?RAT P)"
      by (metis P dvd_field_iff inv_P invertible_iff_is_unit_JNF map_carrier_mat 
          not_is_unit_0 of_int_hom.hom_0 of_int_hom.hom_det)
    have "det (?RAT (mat_of_rows n fs_init)) = det (?RAT P) * det (?RAT (mat_of_rows n gs))"
      by (metis Determinant.det_mult P fs_P_gs gs_carrier of_int_hom.hom_det of_int_hom.hom_mult)
    hence "det (?RAT (mat_of_rows n gs))  0" using d by auto 
    thus "invertible_mat (?RAT (mat_of_rows n gs))"
      by (meson dvd_field_iff gs_carrier invertible_iff_is_unit_JNF map_carrier_mat)
  qed
qed


corollary lattice_of_eq_via_HNF:
  assumes sound_HNF: "is_sound_HNF HNF associates res"
    and P1_H1: "(P1,H1) = HNF (mat_of_rows n fs_init)"
    and P2_H2: "(P2,H2) = HNF (mat_of_rows n gs)"    
    and gs: "set gs  carrier_vec n"     
    and mn: "m = n" and len_gs: "length gs = n"
  shows "(H1 = H2)  (lattice_of fs_init = lattice_of gs)"
  using certification_via_eq_HNF certification_via_eq_HNF2 assms by metis
end



context
begin

interpretation vec_module "TYPE(int)" n .

lemma lattice_of_eq_via_HNF_paper:
  fixes F G :: "int mat" and HNF :: "int mat  int mat"
  assumes sound_HNF': "is_sound_HNF' HNF 𝒜 " (* HNF is a sound algorithm *)  
    and inv_F_Q: "invertible_mat (map_mat rat_of_int F)" (* invertible over Q *)
    and FG: "{F,G}  carrier_mat n n"
  shows "(HNF F = HNF G)  (lattice_of (rows F) = lattice_of (rows G))"
proof -
  define HNF' 
    where "HNF' = (λA. let H = HNF A 
    in (SOME P. P  carrier_mat (dim_row A) (dim_row A)  invertible_mat P  A = P * H, H))"
  have sound_HNF': "is_sound_HNF HNF' 𝒜 " by (unfold HNF'_def, rule is_sound_HNF_conv[OF sound_HNF'])
  have F_eq: "F = mat_of_rows n (rows F)" and G_eq: "G = mat_of_rows n (rows G)"
    using FG by auto
  interpret L: LLL_with_assms n n "(rows F)" "4/3"
  proof 
    interpret gs: cof_vec_space n "TYPE(rat)" .
    thm gs.upper_triangular_imp_lin_indpt_rows
  let ?RAT ="map_mat rat_of_int"
    have m_rw: "(map (map_vec rat_of_int) (rows F)) = rows (?RAT F)"
      unfolding Matrix.rows_def by auto
    show "gs.lin_indpt_list (map (map_vec rat_of_int) (rows F))"
    proof -
      have det_RAT_F: "det (?RAT F)  0"         
        by (metis inv_F_Q carrier_mat_triv invertible_iff_is_unit_JNF 
            invertible_mat_def not_is_unit_0 square_mat.simps)
      have d_RAT_F: "distinct (rows (?RAT F))"
      proof (rule ccontr)
        assume "¬ distinct (rows (?RAT F))" 
        from this obtain i j 
          where ij: "row (?RAT F) i = row (?RAT F) j"
            and i: "i<dim_row (?RAT F)" and j: "j<dim_row (?RAT F)" 
            and i_not_j: "ij"
          unfolding Matrix.rows_def distinct_conv_nth by auto
        have "det (?RAT F) = 0" using ij i j i_not_j
          by (metis Determinant.det_def Determinant.det_identical_rows carrier_mat_triv)
        thus False using inv_F_Q
          by (metis carrier_mat_triv invertible_iff_is_unit_JNF invertible_mat_def 
              not_is_unit_0 square_mat.simps)
      qed     
      moreover have "¬ gs.lin_dep (set (rows (?RAT F)))"
        using gs.det_not_0_imp_lin_indpt_rows[OF _ det_RAT_F] using FG by auto
      ultimately show ?thesis
        unfolding gs.lin_indpt_list_def m_rw using FG unfolding Matrix.rows_def by auto      
    qed 
  qed (insert FG F_eq, auto)
  show ?thesis 
  proof (rule L.lattice_of_eq_via_HNF[OF sound_HNF'])
    show "(fst (HNF' F), HNF F) = HNF' (mat_of_rows n (rows F))" 
      unfolding HNF'_def Let_def using F_eq by auto
    show "(fst (HNF' G), HNF G) = HNF' (mat_of_rows n (rows G))" 
      unfolding HNF'_def Let_def using G_eq by auto
    show "length (rows G) = n " using FG by auto
    show "set (rows G)  carrier_vec n" using FG
      by (metis G_eq mat_of_rows_carrier(3) rows_carrier)
  qed (simp)
qed
end

text ‹We define a new const similar to @{text "external_lll_solver"},
but now it only returns the reduced matrix.›

consts external_lll_solver' :: "integer × integer  integer list list  integer list list" 

hide_type (open) Finite_Cartesian_Product.vec


text ‹The following definition is an adaptation of @{text "reduce_basis_external"}

definition reduce_basis_external' :: "(int mat  int mat)  rat  int vec list  int vec list" where
  "reduce_basis_external' HNF α fs = (case fs of Nil  [] | Cons f _  (let 
    rb = reduce_basis α;
    fsi = map (map integer_of_int o list_of_vec) fs;
    n = dim_vec f;
    m = length fs;
    gsi = external_lll_solver' (map_prod integer_of_int integer_of_int (quotient_of α)) fsi;
    gs = (map (vec_of_list o map int_of_integer) gsi) in
    if ¬ (length gs = m  ( gi  set gs. dim_vec gi = n)) then
      Code.abort (STR ''error in external LLL invocation: dimensions of reduced basis do not fit⏎input to external solver: ''
        + String.implode (show fs) + STR ''⏎⏎'') (λ _. rb fs)
     else 
      let Fs = mat_of_rows n fs;
          Gs = mat_of_rows n gs;
          H1 = HNF Fs;
          H2 = HNF Gs in 
           if (H1 = H2) then rb gs 
          else Code.abort (STR ''the reduced matrix does not span the same lattice⏎f,g,P1,P2,H1,H2 are as follows⏎''
            + String.implode (show Fs) + STR ''⏎⏎''
            + String.implode (show Gs) + STR ''⏎⏎''
            + String.implode (show H1) + STR ''⏎⏎''
            + String.implode (show H2) + STR ''⏎⏎''
            ) (λ _. rb fs))
    )" 

locale certification = LLL_with_assms +
  fixes HNF::"int mat  int mat" and associates res (*HNF operation without explicit transformation matrix*)
  assumes sound_HNF': "is_sound_HNF' HNF associates res"
begin

lemma reduce_basis_external': assumes res: "reduce_basis_external' HNF α fs_init = fs" 
  shows "reduced fs m" "LLL_invariant True m fs" 
proof (atomize(full), goal_cases)
  case 1
  show ?case
  proof (cases "LLL_Impl.reduce_basis α fs_init = fs")
    case True   
    from reduce_basis[OF this] show ?thesis by simp
  next
    case False note a = False
    show ?thesis
    proof (cases fs_init)
      case Nil
      with res have "fs = []" unfolding reduce_basis_external'_def by auto
      with False Nil have False by (simp add: LLL_Impl.reduce_basis_def)
      thus ?thesis ..
    next
      case (Cons f rest) 
      from Cons fs_init len have dim_fs_n: "dim_vec f = n" by auto
      let ?ext = "external_lll_solver' (map_prod integer_of_int integer_of_int (quotient_of α)) 
        (map (map integer_of_int  list_of_vec) fs_init)" 
      note res = res[unfolded reduce_basis_external'_def Cons Let_def list.case Code.abort_def dim_fs_n,
          folded Cons]
      define gs where "gs = map (vec_of_list o map int_of_integer) ?ext" 
      define Fs where "Fs = mat_of_rows n fs_init"
      define Gs where "Gs = mat_of_rows n gs"
      define H1 where "H1 = HNF Fs"
      define H2 where "H2 = HNF Gs"
      note res = res[unfolded ext option.simps split len dim_fs_n, folded gs_def]
      from res False have not: "(¬ (length gs = m  (giset gs. dim_vec gi = n))) = False" 
        by (auto split: if_splits)
      note res = res[unfolded this if_False]
      from not have gs: "set gs  carrier_vec n" 
        and len_gs: "length gs = m" by auto
      show ?thesis
      proof (cases "H1 = H2")
        case True
        hence H1_eq_H2: "H1 = H2" by auto
        let ?HNF = "(λA. let H = HNF A in (SOME P. P  carrier_mat (dim_row A) (dim_row A)  invertible_mat P  A = P * H, H))"
        obtain P1 where P1_H1: "(P1,H1) = ?HNF Fs" by (metis H1_def)
        obtain P2 where P2_H2: "(P2,H2) = ?HNF Gs" by (metis H2_def)
        have sound_HNF: "is_sound_HNF ?HNF associates res"
          by (rule is_sound_HNF_conv[OF sound_HNF'])
        have laticce_gs_fs_init: "lattice_of gs = lattice_of fs_init" 
          and gs_assms: "LLL_with_assms n m gs α"
          by (rule certification_via_eq_HNF[OF sound_HNF P1_H1[unfolded Fs_def] 
                P2_H2[unfolded Gs_def] H1_eq_H2 gs len_gs])+
        from res a True   
        have gs_fs:  "LLL_Impl.reduce_basis α gs = fs"  by (auto split:  prod.split) 
        have lattice_gs_fs: "lattice_of gs = lattice_of fs" 
          and "gram_schmidt_fs.reduced n (map of_int_hom.vec_hom fs) α m" 
          and "gs.lin_indpt_list (map of_int_hom.vec_hom fs)"
          and "length fs = length gs" 
          using LLL_with_assms.reduce_basis gs_fs gs_assms laticce_gs_fs_init gs_assms 
          using LLL_with_assms_def len_gs unfolding LLL.L_def by fast+             
        from this show ?thesis
          using laticce_gs_fs_init gs_assms LLL_with_assms_def lattice_gs_fs
          unfolding LLL_invariant_def L_def by auto               
      next
        case False
        then show ?thesis 
          using a Fs_def Gs_def res H1_def H2_def by auto
      qed
    qed
  qed
qed
end

context LLL_with_assms
begin

text ‹We interpret the certification context using our formalized @{text "HNF_algorithm"}

interpretation efficient_cert: certification n m fs_init α "HNF_algorithm use_sym_mod" "range ass_function_euclidean" "λc. range (res_int c)"  
  by (unfold_locales, rule is_sound_HNF'_HNF_algorithm)

(*We get the final lemma for our algorithm. It works for any matrix, but it only applies operations
modulo determinant for non-singular matrices.*)
thm efficient_cert.reduce_basis_external' 

text ‹Same, but applying the naive HNF algorithm, moved to JNF library from the echelon form 
  and Hermite normal form AFP entries›

interpretation cert: certification n m fs_init α "HNF_algorithm_from_HA use_sym_mod" "range ass_function_euclidean" "λc. range (res_int c)"  
  by (unfold_locales, rule is_sound_HNF'_HNF_algorithm_from_HA)
thm cert.reduce_basis_external'

(*Explicit versions for paper-presentation:*)
lemma RBE_HNF_algorithm_efficient:
  assumes "reduce_basis_external' (HNF_algorithm use_sym_mod) α fs_init = fs"
  shows "gram_schmidt_fs.reduced n (map of_int_hom.vec_hom fs) α m"
    and "LLL_invariant True m fs" using efficient_cert.reduce_basis_external' assms by blast+

lemma RBE_HNF_algorithm_naive:
  assumes "reduce_basis_external' (HNF_algorithm_from_HA use_sym_mod) α fs_init = fs"
  shows "gram_schmidt_fs.reduced n (map of_int_hom.vec_hom fs) α m"
    and "LLL_invariant True m fs" using cert.reduce_basis_external' assms by blast+

end

lemma external_lll_solver'_code[code]: 
  "external_lll_solver' = Code.abort (STR ''require proper implementation of external_lll_solver'') (λ _. external_lll_solver')" 
  by simp
end